Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/FLINT/opt/lcontract.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/opt/lcontract.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

sml/branches/SMLNJ/src/compiler/FLINT/opt/lcontract.sml revision 24, Thu Mar 12 00:49:58 1998 UTC sml/trunk/src/compiler/FLINT/opt/lcontract.sml revision 202, Sun Dec 13 02:29:45 1998 UTC
# Line 3  Line 3 
3    
4  signature LCONTRACT =  signature LCONTRACT =
5  sig  sig
6    val lcontract : Lambda.lexp -> Lambda.lexp    val lcontract : FLINT.prog -> FLINT.prog
7  end  end
8    
9  structure LContract : LCONTRACT =  structure LContract : LCONTRACT =
10  struct  struct
11    
12  local structure DI = DebIndex  local structure DI = DebIndex
13        open Access Lambda        structure DA = Access
14          structure LT = LtyExtern
15          structure FU = FlintUtil
16          structure PO = PrimOp
17          open FLINT
18  in  in
19    
20  val sameName = LambdaVar.sameName  fun bug s = ErrorMsg.impossible ("LContract: "^s)
21  fun bug s = ErrorMsg.impossible ("LambdaOpt: "^s)  val say = Control.Print.say
22  val ident = fn le => le  val ident = fn x => x
23  fun all p (a::r) = p a andalso all p r | all p nil = true  fun all p (a::r) = p a andalso all p r | all p nil = true
24    
25  fun isDiff(x, VAR v) = (x <> v)  fun isDiffs (vs, us) =
26    | isDiff(x, GENOP({default,table}, _, _, _)) =    let fun h (VAR x) = List.all (fn y => (y<>x)) vs
27        (x <> default) andalso (all (fn (_, w) => (x <> w)) table)          | h _ = true
28    | isDiff _ = true     in List.all h us
29      end
30    
31    fun isEqs (vs, us) =
32      let fun h (v::r, (VAR x)::z) = if v = x then h(r, z) else false
33            | h ([], []) = true
34            | h _ = false
35       in h(vs, us)
36      end
37    
38  datatype info  datatype info
39    = CompExp    = SimpVal of value
   | SimpVal of value  
40    | ListExp of value list    | ListExp of value list
41    | FunExp of lvar * lty * lexp    | FunExp of lvar list * lexp
42    | SimpExp    | ConExp of dcon * tyc list * value
43      | StdExp
 fun isPure(SVAL _) = true  
   | isPure(RECORD _) = true  
   | isPure(SRECORD _) = true  
   | isPure(VECTOR _) = true  
   | isPure(SELECT _) = true  
   | isPure(FN _) = true  
   | isPure(TFN _) = true  
   | isPure(CON _) = true  
   | isPure(DECON _) = true (* this can be problematic *)  
   | isPure(ETAG _) = true  
   | isPure(PACK _) = true  
   | isPure(WRAP _) = true  
   | isPure(UNWRAP _) = true  
   | isPure(SWITCH(v, _, ces, oe)) =  
       let fun g((_,x)::r) = if isPure x then g r else false  
             | g [] = case oe of NONE => true | SOME z => isPure z  
        in g ces  
       end  
   | isPure _ = false  
   (*** the cases for FIX and LET have already been flattened, thus  
        they should not occur ***)  
44    
45  exception LContPass1  exception LContPass1
46  fun pass1 lexp =  fun pass1 fdec =
47    let val zz : (DI.depth option) Intmap.intmap = Intmap.new(32, LContPass1)    let val zz : (DI.depth option) Intmap.intmap = Intmap.new(32, LContPass1)
48        val add = Intmap.add zz        val add = Intmap.add zz
49        val get = Intmap.map zz        val get = Intmap.map zz
# Line 65  Line 55 
55               val _ = rmv x               val _ = rmv x
56            in case s            in case s
57                of NONE => ()                of NONE => ()
58                   | SOME _ => add(x, NONE)  (* depth no longer matters *)
59    (*
60                 | SOME d => if (d=nd) then add(x, NONE)                 | SOME d => if (d=nd) then add(x, NONE)
61                             else ()                             else ()
62    *)
63           end) handle _ => ()           end) handle _ => ()
64    
65        fun cand x = (get x; true) handle _ => false        fun cand x = (get x; true) handle _ => false
66    
67        fun loop (e, d) =        fun lpfd d ({isrec=SOME _,...}, v, vts, e) = lple d e
68            | lpfd d (_, v, vts, e) = (enter(v, d); lple d e)
69    
70          and lple d e =
71          let fun psv (VAR x) = kill x          let fun psv (VAR x) = kill x
72                | psv _ = ()                | psv _ = ()
73    
74              and pse (SVAL v) = psv v              and pst (v, vks, e) = lple (DI.next d) e
75                | pse (FN(v, _, e)) = pse e  
76                | pse (APP(VAR x, v2)) = (mark d x; psv v2)              and pse (RET vs) = app psv vs
77                | pse (APP(v1, v2)) = (psv v1; psv v2)                | pse (LET(vs, e1, e2)) = (pse e1; pse e2)
78                | pse (FIX(vs, ts, es, be)) = (app pse es; pse be)                | pse (FIX(fdecs, e)) = (app (lpfd d) fdecs; pse e)
79                | pse (LET(v, FN (_,_,e1), e2)) = (enter(v, d); pse e1; pse e2)                | pse (APP(VAR x, vs)) = (mark d x; app psv vs)
80                | pse (LET(v, e1, e2)) = (pse e1; pse e2)                | pse (APP(v, vs)) = (psv v; app psv vs)
81                | pse (TFN(ks, e)) = loop(e, DI.next d)                | pse (TFN(tfdec, e)) = (pst tfdec; pse e)
82                | pse (TAPP(v, _)) = psv v                | pse (TAPP(v, _)) = psv v
83                | pse (VECTOR(vs,_)) = app psv vs                | pse (RECORD(_,vs,_,e)) = (app psv vs; pse e)
84                | pse (RECORD vs) = app psv vs                | pse (SELECT(u,_,_,e)) = (psv u; pse e)
85                | pse (SRECORD vs) = app psv vs                | pse (CON(_,_,u,_,e)) = (psv u; pse e)
86                | pse (SELECT(_,v)) = psv v                | pse (SWITCH(u, _, ces, oe)) =
87                | pse (CON(_,_,v)) = psv v                    (psv u; app (fn (_,x) => pse x) ces;
               | pse (DECON(_,_,v)) = psv v  
               | pse (SWITCH(v, _, ces, oe)) =  
                   (psv v; app (fn (_,x) => pse x) ces;  
88                     case oe of NONE => () | SOME x => pse x)                     case oe of NONE => () | SOME x => pse x)
               | pse (ETAG(v, _)) = psv v  
               | pse (HANDLE(e,v)) = (pse e; psv v)  
               | pse (PACK(_,_,_,v)) = psv v  
               | pse (WRAP(_,_,v)) = psv v  
               | pse (UNWRAP(_,_,v)) = psv v  
89                | pse (RAISE _) = ()                | pse (RAISE _) = ()
90                  | pse (HANDLE(e,v)) = (pse e; psv v)
91                  | pse (BRANCH(_, vs, e1, e2)) = (app psv vs; pse e1; pse e2)
92                  | pse (PRIMOP(_, vs, _, e)) = (app psv vs; pse e)
93    
94           in pse e           in pse e
95          end          end
96    
97     in loop (lexp, DI.top); cand     in lpfd DI.top fdec; (cand, fn () => Intmap.clear zz)
98    end    end (* pass1 *)
99    
100  (************************************************************************  (************************************************************************
101   *                      THE MAIN FUNCTION                               *   *                      THE MAIN FUNCTION                               *
102   ************************************************************************)   ************************************************************************)
103  fun lcontract lexp =  fun lcontract (fdec, init) =
104  let  let
105    
106  val isCand = pass1 lexp  (* In pass1, we calculate the list of functions that are the candidates
107     * for contraction. To be such a candidate, a function must be called
108     * only once, and furthermore, the call site must be at the same
109     * depth as the definition site. (ZHONG)
110     *
111     * Being at the same depth is not strictly necessary, we'll relax this
112     * constraint in the future.
113     *)
114    val (isCand, cleanUp) =
115     if init then (fn _ => false, fn () => ()) else pass1 fdec
116    
117  exception LContract  exception LContract
118  val m : (int ref * info) Intmap.intmap = Intmap.new(32, LContract)  val m : (int ref * info) Intmap.intmap = Intmap.new(32, LContract)
# Line 123  Line 123 
123    
124  fun chkIn (v, info) = enter(v, (ref 0, info))  fun chkIn (v, info) = enter(v, (ref 0, info))
125    
126  fun refer v =  (** check if a variable is dead *)
127    ((case get v  fun dead v = (case get v of (ref 0, _) => true
128       of (_, SimpVal sv) => SOME sv                            | _ => false) handle _ => false
129        | (x, _) => (x := (!x) + 1; NONE)) handle _ => NONE)  
130    fun once v = (case get v of (ref 1, _) => true | _ => false) handle _ => false
131    
132    (** check if all variables are dead *)
133    fun alldead [] = true
134      | alldead (v::r) = if dead v then alldead r else false
135    
136  fun selInfo v = (SOME(get v)) handle _ => NONE  (** renaming a value *)
137    fun rename (u as (VAR v)) =
138          ((case get v
139             of (_, SimpVal sv) => rename sv
140              | (x, _) => (x := (!x) + 1; u)) handle _ => u)
141      | rename u = u
142    
143  fun chkOut v =  (** selecting a field from a potentially known record *)
144    (let val x = get v  fun selInfo (VAR v, i)  =
145      in kill v; SOME x        ((case get v
146     end handle _ => NONE)           of (_, SimpVal u) => selInfo (u, i)
147              | (_, ListExp vs) =>
   
 fun mkInfo (_, RECORD vs) = ListExp vs  
   | mkInfo (_, SRECORD vs) = ListExp vs  
   | mkInfo (v, SELECT(i, VAR x)) =  
       let fun h z =  
             (case selInfo z  
               of SOME(_, ListExp vs) =>  
148                     let val nv = List.nth(vs, i)                     let val nv = List.nth(vs, i)
149                           handle _ => bug "unexpected List.Nth in SELECT"                             handle _ => bug "unexpected List.Nth in selInfo"
150                      in SimpVal nv                 in SOME nv
151                     end                     end
152                 | SOME(_, SimpVal (VAR w)) => h w            | _ => NONE) handle _ => NONE)
153                 | _ => SimpExp)    | selInfo _ = NONE
154          in h x  
155    (** applying a switch to a data constructor *)
156    fun swiInfo (VAR v, ces, oe) =
157          ((case get v
158             of (_, SimpVal u) => swiInfo(u, ces, oe)
159              | (_, ConExp (dc as (_,rep,_), ts, u)) =>
160                   let fun h ((DATAcon(dc as (_,nrep,_),ts,x),e)::r) =
161                             if rep=nrep then SOME(LET([x], RET [u], e)) else h r
162                         | h (_::r) = bug "unexpected case in swiInfo"
163                         | h [] = oe
164                    in h ces
165         end         end
166              | _ => NONE) handle _ => NONE)
167      | swiInfo _ = NONE
168    
169    | mkInfo (v, e as FN x) = if isCand v then FunExp x else SimpExp  (** contracting a function application *)
170    | mkInfo (_, e) = if isPure e then SimpExp else CompExp  fun appInfo (VAR v) =
171          ((case get v
172             of (ref 0, FunExp (vs, e)) => SOME (vs, e)
173              | _ => NONE) handle _ => NONE)
174      | appInfo _ = NONE
175    
176    
177    (** A very ad-hoc implementation of branch/switch eliminations *)
178    local
179    
180    fun isBoolLty lt =
181      (case LT.ltd_arrow lt
182        of (_, [at], [rt]) =>
183             (LT.lt_eqv(at, LT.ltc_unit)) andalso (LT.lt_eqv(rt, LT.ltc_bool))
184         | _ => false)
185    
186    fun isBool true (RECORD(RK_TUPLE _, [], x,
187                      CON((_,DA.CONSTANT 1,lt), [], VAR x', v, RET [VAR v']))) =
188          (x = x') andalso (v = v') andalso (isBoolLty lt)
189      | isBool false (RECORD(RK_TUPLE _, [], x,
190                      CON((_,DA.CONSTANT 0,lt), [], VAR x', v, RET [VAR v']))) =
191          (x = x') andalso (v = v') andalso (isBoolLty lt)
192      | isBool _ _ = false
193    
194    (* functions that do the branch optimizations *)
195    fun boolDcon((DATAcon((_,DA.CONSTANT 1,lt1),[],v1), e1),
196                 (DATAcon((_,DA.CONSTANT 0,lt2),[],v2), e2)) =
197          if (isBoolLty lt1) andalso (isBoolLty lt2) then
198            SOME(RECORD(FU.rk_tuple,[],v1,e1), RECORD(FU.rk_tuple,[],v2,e2))
199          else NONE
200      | boolDcon(ce1 as (DATAcon((_,DA.CONSTANT 0,_),[],_), _),
201                 ce2 as (DATAcon((_,DA.CONSTANT 1,_),[],_), _)) =
202          boolDcon (ce2, ce1)
203      | boolDcon _ = NONE
204    
205    fun ssplit (LET(vs,e1,e2)) = (fn x => LET(vs,x,e2), e1)
206      | ssplit e = (ident, e)
207    
208    in
209    
210    fun branchopt([v], e1 as (BRANCH(p, us, e11, e12)), e2) =
211          let val (hdr, se2) = ssplit e2
212           in case se2
213               of SWITCH(VAR nv, _, [ce1, ce2], NONE) =>
214                    if (once v) andalso (nv = v) andalso (isBool true e11)
215                       andalso (isBool false e12)
216                    then (case boolDcon (ce1, ce2)
217                           of SOME (e21, e22) => SOME(hdr(BRANCH(p, us, e21, e22)))
218                            | NONE => NONE)
219                    else NONE
220                | _ => NONE
221          end
222      | branchopt _ = NONE
223    
224    end (* branchopt local *)
225    
226    
227    (** the main transformation function *)
228    
229  fun lpacc (LVAR v) =       fun lpacc (DA.LVAR v) =
230        (case lpsv (VAR v)             (case lpsv (VAR v) of VAR w => DA.LVAR w
         of VAR w => LVAR w  
231           | _ => bug "unexpected in lpacc")           | _ => bug "unexpected in lpacc")
232    | lpacc _ = bug "unexpected path in lpacc"    | lpacc _ = bug "unexpected path in lpacc"
233    
234  and lpdc (s, EXN acc, t) = (s, EXN(lpacc acc), t)       and lpdc (s, DA.EXN acc, t) = (s, DA.EXN(lpacc acc), t)
235    | lpdc x = x         | lpdc (s, rep, t) = (s, rep, t)
236    
237  and lpcon (DATAcon dc) = DATAcon(lpdc dc)       and lpcon (DATAcon (dc, ts, v)) = DATAcon(lpdc dc, ts, v)
238    | lpcon c = c    | lpcon c = c
239    
240  and lpdt {default=v, table=ws} =  and lpdt {default=v, table=ws} =
241    let fun h x = case (refer x)             let fun h x =
242                   of SOME(VAR nv) => nv                   case rename (VAR x) of VAR nv => nv
243                    | NONE => x                                        | _ => bug "unexpected acse in lpdt"
244     in {default=h v, table=map (fn (ts,w) => (ts,h w)) ws}              in (SOME {default=h v, table=map (fn (ts,w) => (ts,h w)) ws})
245    end             end
246    
247  and lpsv x =       and lpsv x = (case x of VAR v => rename x | _ => x)
248    (case x  
249      of VAR v => (case (refer v) of SOME nsv => lpsv nsv       and lpfd ({isrec, known, inline, cconv}, v, vts, e) =
250                                   | NONE => (x : value))           (* The function body might have changed so we need to reset
251       | GENOP(dict, p, lt, ts) => GENOP(lpdt dict, p, lt, ts)            * the inlining hint *)
252       | _ => x)           ({isrec=isrec, known=known, inline=IH_SAFE, cconv=cconv},
253              v, vts, #1(loop e))
254    
255         and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =
256           let val _ = chkIn(v, info)
257               val (ne, b) = loop e
258            in if pure then (if dead v then (ne, b) else (hdr ne, b))
259               else (hdr ne, false)
260           end (* function lplet *)
261    
262  and loop le =  and loop le =
263    (case le    (case le
264      of SVAL v => SVAL(lpsv v)           of RET vs => (RET (map lpsv vs), true)
265       | FN(v, t, e) => FN(v, t, loop e)            | LET(vs, RET us, e) =>
266       | APP(v1 as VAR x, v2) =>                (ListPair.app chkIn (vs, map SimpVal us); loop e)
267           (case selInfo x            | LET(vs, LET(us, e1, e2), e3) =>
268             of SOME(ref c, FunExp(z,_,b)) =>                loop(LET(us, e1, LET(vs, e2, e3)))
269                 (if (c = 0) then loop(LET(z, SVAL v2, b))            | LET(vs, FIX(fdecs, e1), e2) =>
270                  else bug "unexpected FunExp in APP")                loop(FIX(fdecs, LET(vs, e1, e2)))
271  (* commented out because it won't have any effect for the time being.            | LET(vs, TFN(tfd, e1), e2) =>
272              | SOME(_, SimpVal (y as VAR _)) => loop(APP(y, v2))                loop(TFN(tfd, LET(vs, e1, e2)))
273  *)            | LET(vs, CON(dc, ts, u, v, e1), e2) =>
274              | _ => APP(lpsv v1, lpsv v2))                loop(CON(dc, ts, u, v, LET(vs, e1, e2)))
275       | APP(v1, v2) => APP(lpsv v1, lpsv v2)            | LET(vs, RECORD(rk, us, v, e1), e2) =>
276       | FIX(vs, ts, es, b) =>                loop(RECORD(rk, us, v, LET(vs, e1, e2)))
277           let fun g ((FN _)::r) = g r            | LET(vs, SELECT(u, i, v, e1), e2) =>
278                 | g (_::r) = false                loop(SELECT(u, i, v, LET(vs, e1, e2)))
279                 | g [] = true            | LET(vs, PRIMOP(p, us, v, e1), e2) =>
280               val _ = if g es then () else bug "unexpected cases in loop-FIX"                loop(PRIMOP(p, us, v, LET(vs, e1, e2)))
281               val _ = app (fn x => chkIn(x, SimpExp)) vs            | LET(vs, e1, e2 as (RET us)) =>
282               val nb = loop b                if isEqs(vs, us) then loop e1
283               val ws = map chkOut vs                else let val (ne1, b1) = loop e1
284                           val nus = map lpsv us
285               fun h ((SOME(ref 0, _))::r) = h r                      in if (isDiffs(vs, nus)) andalso b1 then (RET nus, true)
286                 | h (_::r) = false                         else (LET(vs, ne1, RET nus), b1)
287                 | h [] = true                     end
288            in if h ws then nb            | LET(vs, e1, e2) =>
289               else FIX(vs, ts, map loop es, nb)                let val _ = app (fn v => chkIn(v, StdExp)) vs
290           end                    val (ne1, b1) = loop e1
291       | LET(v, LET(u, e1, e2), e3) =>                    val (ne2, b2) = loop e2
292           loop(LET(u, e1, LET(v, e2, e3)))                 in if (alldead vs) andalso b1 then (ne2, b2)
293       | LET(v, FIX(vs, ts, es, b), e) =>                    else (case branchopt(vs, ne1, ne2)
294           loop(FIX(vs, ts, es, LET(v, b, e)))                           of SOME xx => (xx, b1 andalso b2)
295       | LET(v, SVAL sv, e2) =>                            | NONE =>
296           (chkIn(v, SimpVal sv); loop e2)                                (case ne2
297       | LET(v, e1, e2 as SVAL (VAR x)) =>                                  of (RET us) =>
298           if (v = x) then loop e1                                       if isEqs(vs, us) then (ne1, b1)
299           else if isPure e1 then loop e2                                       else (LET(vs, ne1, ne2), b1)
300                else LET(v, loop e1, loop e2)                                   | _ => (LET(vs, ne1, ne2), b1 andalso b2)))
301       | LET(v, e1 as FN(v1, t1, b1), e2 as APP(VAR x, sv)) =>                end
302           if isDiff(v, sv) then  
303             (if (v = x) then loop(LET(v1, SVAL sv, b1)) else loop e2)            | FIX(fdecs, e) =>
304           else LET(v, loop e1, loop e2)                let fun g ({isrec=SOME _, ...} :fkind, v, _, _) =
305       | LET(v, e1, e2) =>                           chkIn(v, StdExp)
306           let val _ = chkIn(v, mkInfo(v,e1))                      | g ((_, v, vts, xe) : fundec) =
307               val ne2 = loop e2                           chkIn(v, if isCand v then FunExp(map #1 vts, xe)
308               val w = chkOut v                                    else StdExp)
309            in case w                    val _ = app g fdecs
310                of SOME(_, CompExp) => LET(v, loop e1, ne2)                    val (ne, b) = loop e
311                 | SOME(ref 0, _) => ne2                 in if alldead (map #2 fdecs) then (ne, b)
312                 | _ => (case (e1, ne2)                    else (FIX(map lpfd fdecs, ne), b)
313                          of (FN(v1,t1,b1), APP(VAR x, sv)) =>                end
314                               if isDiff(v, sv) then            | APP(u, us) =>
315                                (if (v=x) then loop(LET(v1, SVAL sv,b1))                (case appInfo u
316                                 else ne2)                  of SOME(vs, e) =>
317                               else LET(v, loop e1, ne2)                       let val ne = LET(vs, RET us, e)
318                           | (_, SVAL(VAR x)) =>                        in loop ne
319                               if isPure e1 then (if v=x then loop e1                       end
320                                                  else ne2)                   | _ => (APP(lpsv u, map lpsv us), false))
321                               else LET(v, loop e1, ne2)  
322                           | _ => LET(v, loop e1, ne2))            | TFN(tfdec as (v, tvks, xe), e) =>
323           end                lplet ((fn z => TFN((v, tvks,
324       | TFN(ks, e) => TFN(ks, loop e)                                #1(loop xe)), z)),
325       | TAPP(v, ts) => TAPP(lpsv v, ts)                       true, v, StdExp, e)
326       | VECTOR(vs, t) => VECTOR(map lpsv vs, t)            | TAPP(u, ts) => (TAPP(lpsv u, ts), true)
327       | RECORD vs => RECORD (map lpsv vs)  
328       | SRECORD vs => SRECORD (map lpsv vs)            | CON(c, ts, u, v, e) =>   (* this could be made more finegrain *)
329       | SELECT(i, v as VAR x) =>                lplet ((fn z => CON(lpdc c, ts, lpsv u, v, z)),
330           (case selInfo x                       true, v, ConExp(c,ts,u), e)
            of SOME(_, ListExp vs) =>  
                 let val nv = List.nth(vs, i)  
                       handle _ => bug "unexpected List.Nth in SELECT"  
                  in SVAL(lpsv nv)  
                 end  
             | SOME(_, SimpVal (y as VAR _)) => loop(SELECT(i, y))  
             | _ => SELECT(i, lpsv v))  
      | SELECT(i, v) => SELECT(i, lpsv v)  
      | CON(c, ts, v) => CON(lpdc c, ts, lpsv v)  
      | DECON(c, ts, v) => DECON(lpdc c, ts, lpsv v)  
331       | SWITCH (v, cs, ces, oe) =>       | SWITCH (v, cs, ces, oe) =>
332           let val nv = lpsv v                (case swiInfo(v, ces, oe)
333               val nces = map (fn (c, e) => (lpcon c, loop e)) ces                  of SOME ne => loop ne
334               val noe = case oe of NONE => NONE | SOME e => SOME (loop e)                   | _ => let val nv = lpsv v
335            in SWITCH(nv, cs, nces, noe)                              fun h ((c, e), (es, b)) =
336           end                                let val nc = lpcon c
337       | ETAG(v, t) => ETAG(lpsv v, t)                                    val (ne, nb) = loop e
338       | RAISE(v, t) => RAISE(lpsv v, t)                                 in ((nc, ne)::es, nb andalso b)
339       | HANDLE(e, v) => HANDLE(loop e, lpsv v)                                end
340       | PACK(t, ts1, ts2, v) => PACK(t, ts1, ts2, lpsv v)                              val (nces, ncb) = foldr h ([], true) ces
341       | WRAP(t, b, v) => WRAP(t, b, lpsv v)                              val (noe, nb) =
342       | UNWRAP(t, b, v) => UNWRAP(t, b, lpsv v))                                case oe
343                                   of NONE => (NONE, ncb)
344                                    | SOME e => let val (ne, b) = loop e
345                                                 in (SOME ne, b andalso ncb)
346                                                end
347                             in (SWITCH(nv, cs, nces, noe), nb)
348                            end)
349    
350              | RECORD (rk, us, v, e) =>
351                  lplet ((fn z => RECORD(rk, map lpsv us, v, z)),
352                         true, v, ListExp us, e)
353              | SELECT(u, i, v, e) =>
354                  (case selInfo (u, i)
355                    of SOME nv => (chkIn(v, SimpVal nv); loop e)
356                     | NONE => lplet ((fn z => SELECT(lpsv u, i, v, z)),
357                                      true, v, StdExp, e))
358    
359              | RAISE(v, ts) => (RAISE(lpsv v, ts), false)
360              | HANDLE(e, v) =>
361                  let val (ne, b) = loop e
362                   in if b then (ne, true)
363                      else (HANDLE(ne, lpsv v), false)
364                  end
365    
366              | BRANCH(px as (d, p, lt, ts), vs, e1, e2) =>
367                  let val (ne1, b1) = loop e1
368                      val (ne2, b2) = loop e2
369                   in (BRANCH(case d of NONE => px
370                                      | SOME d => (lpdt d, p, lt, ts),
371                              map lpsv vs, ne1, ne2), false)
372                  end
373              | PRIMOP(px as (dt, p, lt, ts), vs, v, e) =>
374                  lplet ((fn z => PRIMOP((case dt
375                                           of NONE => px
376                                            | SOME d => (lpdt d, p, lt, ts)),
377                                         map lpsv vs, v, z)),
378                         false (* PO.purePrimop p *), v, StdExp, e))
379    
380    val d = DI.top
381    val (fk, f, vts, e) = fdec
382    in (fk, f, vts, #1 (loop e))
383       before (Intmap.clear m; cleanUp())
384    end (* function lcontract *)
385    
386  val nlexp = loop lexp  (** run the lambda contraction twice *)
387  in (Intmap.clear m; nlexp)  val lcontract = fn fdec => lcontract(lcontract(fdec, true), false)
 end  
388    
389  end (* toplevel local *)  end (* toplevel local *)
390  end (* structure LContract *)  end (* structure LContract *)
391    
392    
393    (*
394     * $Log$
395     *)

Legend:
Removed from v.24  
changed lines
  Added in v.202

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0