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/collect.sml
ViewVC logotype

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

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

revision 185, Tue Nov 10 21:01:05 1998 UTC revision 186, Wed Nov 11 05:24:43 1998 UTC
# Line 9  Line 9 
9       * The info is accumulated in the map `m' *)       * The info is accumulated in the map `m' *)
10      val collect : FLINT.fundec -> FLINT.fundec      val collect : FLINT.fundec -> FLINT.fundec
11    
12  (*      val get : FLINT.lvar -> info *)      val get : FLINT.lvar -> info
13    
14      (* query functions *)      (* query functions *)
15      val escaping  : FLINT.lvar -> bool  (* non-call uses *)      val escaping  : info -> bool        (* non-call uses *)
16      val called    : FLINT.lvar -> bool  (* known call uses *)      val called    : info -> bool        (* known call uses *)
17      val usenb     : FLINT.lvar -> int   (* nb of non-recursive uses *)      val usenb     : info -> int (* nb of non-recursive uses *)
18      val actuals   : FLINT.lvar -> (FLINT.value option list) (* constant args *)      val actuals   : info -> (FLINT.value option list) (* constant args *)
19    
20      (* inc the "true=call,false=use" count *)      (* inc the "true=call,false=use" count *)
21      val use    : FLINT.value list option -> FLINT.lvar -> unit      val use    : FLINT.value list option -> info -> unit
22      (* dec the "true=call,false=use" count and call the function if zero *)      (* dec the "true=call,false=use" count and call the function (and return true) if zero *)
23      val unuse  : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> unit      val unuse  : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> bool
24      (* transfer the counts of var1 to var2 *)      (* transfer the counts of var1 to var2 *)
25      val transfer : FLINT.lvar * FLINT.lvar -> unit      val transfer : FLINT.lvar * FLINT.lvar -> unit
26      (* add the counts of var1 to var2 *)      (* add the counts of var1 to var2 *)
27      val addto  : FLINT.lvar * FLINT.lvar -> unit      (*  val addto  : info * info -> unit *)
28      (* delete the last reference to a variable *)      (* delete the last reference to a variable *)
29      val kill   : FLINT.lvar -> unit      val kill   : FLINT.lvar -> unit
30      (* create a new var entry (SOME arg list if fun) initialized to zero *)      (* create a new var entry (SOME arg list if fun) initialized to zero *)
31      val new    : FLINT.lvar list option -> FLINT.lvar -> unit      val new    : FLINT.lvar list option -> FLINT.lvar -> info
32    
33      (* when creating a new var.  Used when alpha-renaming *)      (* when creating a new var.  Used when alpha-renaming *)
34      (* val copy   : FLINT.lvar * FLINT.lvar -> unit *)      (* val copy   : FLINT.lvar * FLINT.lvar -> unit *)
# Line 41  Line 41 
41          ((FLINT.lexp -> unit) *          ((FLINT.lexp -> unit) *
42           ((FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit))           ((FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit))
43      (* function to collect info about a newly created lexp *)      (* function to collect info about a newly created lexp *)
44   (*     val uselexp : FLINT.lexp -> unit *)      val uselexp : FLINT.lexp -> unit
45      (* function to collect info about a newly created lexp *)      (* function to copy (and collect info) a lexp *)
46      val copylexp : FLINT.lvar IntmapF.intmap  -> FLINT.lexp -> FLINT.lexp      val copylexp : FLINT.lvar IntmapF.intmap  -> FLINT.lexp -> FLINT.lexp
47    
48      (* mostly useful for PPFlint *)      (* mostly useful for PPFlint *)
# Line 79  Line 79 
79  local  local
80      structure F  = FLINT      structure F  = FLINT
81      structure M  = Intmap      structure M  = Intmap
82      structure FM = IntmapF      structure FU = FlintUtil
83      structure LV = LambdaVar      structure LV = LambdaVar
84      structure PP = PPFlint      structure PP = PPFlint
85  in  in
# Line 91  Line 91 
91  fun ASSERT (true,_) = ()  fun ASSERT (true,_) = ()
92    | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")    | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
93    
94    exception UnexpectedTransfer
95    
96  datatype info  datatype info
97    (* for functions we keep track of calls and escaping uses *)    (* for functions we keep track of calls and escaping uses *)
98    = Fun of {calls: int ref, uses: int ref, int: int ref,    = Fun of {calls: int ref, uses: int ref,
99              args: (FLINT.lvar * (FLINT.value option)) option list ref}              args: (FLINT.lvar * (FLINT.value option)) option list ref}
100    | Var of int ref      (* for other vars, a simple use count is kept *)    | Var of int ref      (* for other vars, a simple use count is kept *)
101    | Transfer of FLINT.lvar      (* for vars which have been transfered *)    | Transfer of FLINT.lvar      (* for vars which have been transfered *)
102    
103  exception NotFound  exception NotFound
104    
105  val m : info M.intmap = M.new(1024, NotFound)  val m : info M.intmap = M.new(128, NotFound)
106    
107  (* map related helper functions *)  (* map related helper functions *)
108  fun get lv = (M.map m lv)  fun get lv = (M.map m lv)
109                   (* handle x as NotFound =>                    handle x as NotFound =>
110                   (say "\nCollect:get unknown var ";                    (say ("Collect: ERROR: get unknown var "^
111                    PP.printSval (F.VAR lv);                          (LV.lvarName lv)^
112                    say ". Assuming dead...";                          ". Pretending dead...\n");
113                    raise x;                     (*  raise x; *)
114                    Var (ref 0)) *)                     Var (ref 0))
   
 fun new (SOME args) lv =  
     M.add m (lv, Fun{calls=ref 0, uses=ref 0, int=ref 0,  
                      args=ref (map (fn a => SOME(a, NONE)) args)})  
   | new NONE lv = M.add m (lv, Var(ref 0))  
115    
116  fun LVarString lv =  fun LVarString lv =
117      (LV.lvarName lv)^      (LV.lvarName lv)^
118      ((case get lv of      ((case get lv of
119           Var uses => "{"^(Int.toString (!uses))^"}"           Var uses => "{"^(Int.toString (!uses))^"}"
120         | Fun {calls,uses,...} =>         | Fun {calls,uses,...} =>
121           concat ["{", Int.toString (!calls), ",", Int.toString (!uses), "}"]           concat ["{", Int.toString (!uses), ",", Int.toString (!calls), "}"]
122         | Transfer _ => "{-}")         | Transfer lv => "{->"^(LVarString lv)^"}")
123           handle NotFound => "{?}")           handle NotFound => "{?}")
124    
125    fun get' lv = case get lv of Transfer nlv => get' nlv | i => i
126    
127    fun new args lv =
128        let val i =
129                case args
130                 of SOME args => Fun{calls=ref 0, uses=ref 0,
131                                     args=ref (map (fn a => SOME(a, NONE)) args)}
132                  | NONE => Var(ref 0)
133        in M.add m (lv, i); i
134        end
135    
136  (* adds the counts of lv1 to those of lv2 *)  (* adds the counts of lv1 to those of lv2 *)
137  fun addto (lv1,lv2) =  fun addto (info1,info2) =
138      let val info2 = get lv2      case info1
         val info1 = get lv1  
     in case info1  
139          of Var uses1 =>          of Var uses1 =>
140             (case info2             (case info2
141               of Var uses2 => uses2 := !uses2 + !uses1               of Var uses2 => uses2 := !uses2 + !uses1
142                | Fun {uses=uses2,...} => uses2 := !uses2 + !uses1                | Fun {uses=uses2,...} => uses2 := !uses2 + !uses1
143                | Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))             | Transfer _ => raise UnexpectedTransfer)
144           | Fun {uses=uses1,calls=calls1,...} =>           | Fun {uses=uses1,calls=calls1,...} =>
145             (case info2             (case info2
146               of Fun {uses=uses2,calls=calls2,...} =>               of Fun {uses=uses2,calls=calls2,...} =>
147                  (uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)                  (uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)
148                | Var uses2 => uses2 := !uses2 + !uses1                | Var uses2 => uses2 := !uses2 + !uses1
149                | Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))             | Transfer _ => raise UnexpectedTransfer)
150           | Transfer _ => bugval("transfering from a Transfer", F.VAR lv1)        | Transfer _ => raise UnexpectedTransfer
151      end  
152  fun transfer (lv1,lv2) =  fun transfer (lv1,lv2) =
153      (addto(lv1, lv2); M.add m (lv1, Transfer lv2))      (* note the transfer *)      (addto(get lv1, get lv2);
154         (* note the transfer *)
155         M.add m (lv1, Transfer lv2)) handle x => raise x
156    
157  fun inc ri = (ri := !ri + 1)  fun inc ri = (ri := !ri + 1)
158  fun dec ri = (ri := !ri - 1)  fun dec ri = (ri := !ri - 1)
# Line 158  Line 166 
166    | mergearg (SOME(fv,SOME b),a) =    | mergearg (SOME(fv,SOME b),a) =
167      if a = b orelse a = F.VAR fv then SOME(fv,SOME b) else NONE      if a = b orelse a = F.VAR fv then SOME(fv,SOME b) else NONE
168    
169  fun actuals lv =  fun actuals (Var _) = bug "can't query actuals of a var" (* (LVarString lv) *)
170      case get lv    | actuals (Transfer lv) = raise UnexpectedTransfer
171       of Var _ => bug ("can't query actuals of var "^(LVarString lv))    | actuals (Fun{args,...}) = map (fn SOME(_,v) => v | _ => NONE) (!args)
172        | Transfer lv => actuals lv  
173        | Fun{args,...} => map (fn SOME(_,v) => v | _ => NONE) (!args)  fun use call (Var uses) = inc uses
174      | use call (Transfer lv) = raise UnexpectedTransfer
175  fun use call lv =    | use call (Fun {uses,calls,args,...}) =
     case get lv  
      of Var uses => inc uses  
       | Transfer lv => use call lv  
       | Fun {uses,calls,args,...} =>  
176          case call of          case call of
177              NONE => (inc uses; args := map (fn _ => NONE) (!args))              NONE => (inc uses; args := map (fn _ => NONE) (!args))
178            | SOME vals =>            | SOME vals =>
# Line 179  Line 183 
183              if !uses < 0 then              if !uses < 0 then
184                  bugval("decrementing too much", F.VAR lv)                  bugval("decrementing too much", F.VAR lv)
185              else if !uses = 0 then              else if !uses = 0 then
186                  (*  if lv = 1294 then bug "here it is !!" else *) undertaker lv                  (undertaker lv; true)
187              else ()              else false
188      in case get lv      in case get' lv
189          of Var uses => (dec uses; check uses)          of Var uses => (dec uses; check uses)
190           | Fun {uses,calls,...} =>           | Fun {uses,calls,...} =>
191             (dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)             (dec uses; if (call andalso !calls > 0) then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)
192           | Transfer lv => unuse undertaker call lv           | Transfer lv => bug "transfer"
193      end      end handle x => raise x
194    
195  fun usenb lv     = case get lv of (Fun{uses=uses,...} | Var uses) => !uses  fun usenb (Fun{uses=uses,...} | Var uses) = !uses
196                                  | Transfer _ => 0    | usenb (Transfer _) = (raise UnexpectedTransfer; 0)
197  fun used lv      = usenb lv > 0  fun used i      = usenb i > 0
198    
199  fun escaping lv =  fun escaping (Fun{uses,calls,...}) = !uses > !calls
200      case get lv    | escaping (Var us) = !us > 0 (* arbitrary, but hopefully "safe" *)
201       of Fun{uses,calls,...} => !uses > !calls    | escaping (Transfer lv) = raise UnexpectedTransfer
202        | Var us => !us > 0 (* arbitrary, but I opted for the "safe" choice *)  
203        | Transfer lv => (say "\nCollect escaping on transfer"; escaping lv)  fun called (Fun{calls,...}) = !calls > 0
204      | called (Var us) = false (* arbitrary, but consistent with escaping *)
205  fun called lv =    | called (Transfer lv) = raise UnexpectedTransfer
     case get lv  
      of Fun{calls,...} => !calls > 0  
       | Var us => false (* arbitrary, but consistent with escaping *)  
       | Transfer lv => (say "\nCollect escaping on transfer"; called lv)  
206    
207  (* Ideally, we should check that usenb = 1, but we may have been a bit  (* Ideally, we should check that usenb = 1, but we may have been a bit
208   * conservative when keeping the counts uptodate *)   * conservative when keeping the counts uptodate *)
209  fun kill lv = (ASSERT(usenb lv >= 1, concat ["usenb lv >= 1 ", !PP.LVarString lv]); M.rmv m lv)  fun kill lv = (ASSERT(usenb(get' lv) >= 1, "usenb "^(LVarString lv)^" >= 1 ");
210                   M.rmv m lv)
211    
212  (* ********************************************************************** *)  (* ********************************************************************** *)
213  (* ********************************************************************** *)  (* ********************************************************************** *)
# Line 229  Line 230 
230           | [] => None           | [] => None
231      end      end
232    
233  val cplv = LambdaVar.dupLvar  fun impurePO po = true          (* if a PrimOP is pure or not *)
234    
235    val census = let
236        (* val use = if inc then use else unuse *)
237        fun call args lv = use args (get' lv)
238        val use = fn F.VAR lv => use NONE (get' lv) | _ => ()
239        fun newv lv = new NONE lv
240        fun newf args lv = new args lv
241        fun id x = x
242    
243  fun impurePO po = true          (* if a PrimOP is pure or not *)  fun impurePO po = true          (* if a PrimOP is pure or not *)
244    
245  fun census newv substvar alpha uvs le = let      (* here, the use resembles a call, but it's safer to consider it as a use *)
246      val cexp = census newv substvar      fun cpo (NONE:F.dict option,po,lty,tycs) = ()
247      val usevar = substvar NONE alpha        | cpo (SOME{default,table},po,lty,tycs) =
248      fun callvar args lv = substvar (SOME args) alpha lv          (use (F.VAR default); app (use o F.VAR o #2) table)
249      fun use (F.VAR lv) = F.VAR(usevar lv) | use v = v      fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = use (F.VAR lv)
250      fun call args (F.VAR lv) = F.VAR(callvar args lv) | call _ v = v        | cdcon _ = ()
     fun newvs (lvs,alpha) =  
         foldr (fn (lv,(lvs,alpha)) =>  
                let val (nlv,nalpha) = newv NONE (lv,alpha)  
                in (nlv::lvs, nalpha) end)  
               ([],alpha) lvs  
     fun newfs (fdecs,alpha) =  
         foldr (fn ((_,lv,args,_):F.fundec,(lvs,alpha)) =>  
                let val (nlv,nalpha) = newv (SOME(map #1 args)) (lv,alpha)  
                in (nlv::lvs, nalpha) end)  
               ([],alpha) fdecs  
     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =  
         (s, Access.EXN(Access.LVAR(usevar lv)), lty)  
       | cdcon dc = dc  
     fun cpo (SOME{default,table},po,lty,tycs) =  
         (SOME{default=usevar default,  
               table=map (fn (tycs,lv) => (tycs, usevar lv)) table},  
          po,lty,tycs)  
       | cpo po = po  
 in case le  
     of F.RET vs => F.RET(map use vs)  
   
      | F.LET (lvs,le,body) =>  
        let val (nlvs,nalpha) = newvs (lvs,alpha)  
            val nbody = cexp nalpha uvs body  
            val nuvs = usage(map used nlvs)  
            val nle = cexp alpha nuvs le  
        in F.LET(nlvs, nle, nbody)  
        end  
   
      | F.FIX (fdecs,le) =>  
        let val (nfs, nalpha) = newfs(fdecs, alpha)  
   
            (* census of a function *)  
            fun cfun ((fk,f,args,body):F.fundec,nf) =  
                let val (nargs,ialpha) = newvs(map #1 args, nalpha)  
                    val nbody = cexp ialpha All body  
                in (fk, nf, ListPair.zip(nargs, (map #2 args)), nbody)  
                end  
   
            (* some sort of tracing GC on functions *)  
            fun cfix fs = let  
                val (ufs,nfs) = List.partition (used o #2) fs  
            in if List.null ufs then []  
               else (map cfun ufs) @ (cfix nfs)  
            end  
251    
252             val nle = cexp nalpha uvs le      (* the actual function:
253             val nfdecs = cfix(ListPair.zip(fdecs, nfs))       * `uvs' is an optional list of booleans representing which of
254         in       * the return values are actually used *)
255             if List.null nfdecs then nle else F.FIX(nfdecs, nle)      fun cexp uvs lexp =
256         end          (case lexp
257             of F.RET vs => app use vs
258    (*          (case uvs *)
259    (*            of SOME uvs => (* only count vals that are actually used *) *)
260    (*               app (fn(v,uv)=>if uv then use v else ()) (ListPair.zip(vs,uvs)) *)
261    (*             | NONE => app use vs) *)
262    
263       | F.APP (f,args) => F.APP(call args f, map use args)            | F.LET (lvs,le1,le2) =>
264                let val lvsi = map newv lvs
265                in cexp uvs le2; cexp (usage(map used lvsi)) le1
266                end
267    
268       | F.TFN ((lv,args,body),le) =>            | F.FIX (fs,le) =>
269         (* don't forget to rename the tvar also *)              let val fs = map (fn (_,f,args,body) =>
270         let val (nlv,nalpha) = newv (SOME[]) (lv,alpha)                                (newf (SOME(map #1 args)) f,args,body))
271             val nle = cexp nalpha uvs le                               fs
272         in                  fun cfun (_,args,body) = (* census of a fundec *)
273             if used nlv then                      (app (fn (v,t) => ignore(newv v)) args; cexp All body)
274                 let val (nargs,ialpha) = newvs(map #1 args, alpha)                  fun cfix fs =   (* census of a list of fundecs *)
275                     val nbody = cexp ialpha All body                      let val (ufs,nfs) = List.partition (used o #1) fs
276                 in F.TFN((nlv, ListPair.zip(nargs, map #2 args), nbody), nle)                      in if List.null ufs then ()
277                           else (app cfun ufs; cfix nfs)
278                 end                 end
279             else              in cexp uvs le; cfix fs
                nle  
280         end         end
281    
282       | F.TAPP (f,tycs) => F.TAPP(call [] f, tycs)            | F.APP (F.VAR f,vs) =>
283                (call (SOME vs) f; app use vs)
284    
285       | F.SWITCH (v,ac,arms,def) =>            | F.TFN ((tf,args,body),le) =>
286         let fun carm (F.DATAcon(dc,tycs,lv),le) =              let val tfi = newf NONE tf
287                 let val (nlv,nalpha) = newv NONE (lv, alpha)              in cexp uvs le;
288                 in (F.DATAcon(cdcon dc, tycs, nlv), cexp nalpha uvs le)                  if used tfi then cexp All body else ()
                end  
              | carm (con,le) = (con, cexp alpha uvs le)  
        in F.SWITCH(use v, ac, map carm arms, Option.map (cexp alpha uvs) def)  
289         end         end
290    
291       | F.CON (dc,tycs,v,lv,le) =>            | F.TAPP (F.VAR tf,tycs) => call NONE tf
        let val (nlv,nalpha) = newv NONE (lv, alpha)  
            val nle = cexp nalpha uvs le  
        in if used nlv  
           then F.CON(cdcon dc, tycs, use v, nlv, nle)  
           else nle  
        end  
292    
293       | F.RECORD (rk,vs,lv,le) =>            | F.SWITCH (v,cs,arms,def) =>
294         let val (nlv,nalpha) = newv NONE (lv, alpha)              (use v; Option.map (cexp uvs) def;
295             val nle = cexp nalpha uvs le               app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp uvs le)
296         in if used nlv                     | (_,le) => cexp uvs le)
297            then F.RECORD(rk, map use vs, nlv, nle)                   arms)
298            else nle  
299              | F.CON (dc,_,v,lv,le) =>
300                let val lvi = newv lv
301                in cdcon dc; cexp uvs le; if used lvi then use v else ()
302         end         end
303    
304       | F.SELECT (v,i,lv,le) =>            | F.RECORD (_,vs,lv,le) =>
305         let val (nlv,nalpha) = newv NONE (lv, alpha)              let val lvi = newv lv
306             val nle = cexp nalpha uvs le              in cexp uvs le; if used lvi then app use vs else ()
        in if used nlv  
           then F.SELECT(use v, i, nlv, nle)  
           else nle  
307         end         end
308    
309       | F.RAISE (v,ltys) => F.RAISE(use v, ltys)            | F.SELECT (v,_,lv,le) =>
310                let val lvi = newv lv
311                in cexp uvs le; if used lvi then use v else ()
312                end
313    
314       | F.HANDLE (le,v) => F.HANDLE(cexp alpha uvs le, use v)            | F.RAISE (v,_) => use v
315              | F.HANDLE (le,v) => (use v; cexp uvs le)
316    
317       | F.BRANCH (po,vs,le1,le2) =>       | F.BRANCH (po,vs,le1,le2) =>
318         F.BRANCH(cpo po, map use vs, cexp alpha uvs le1, cexp alpha uvs le2)              (app use vs; cpo po; cexp uvs le1; cexp uvs le2)
319    
320       | F.PRIMOP (po,vs,lv,le) =>       | F.PRIMOP (po,vs,lv,le) =>
321         let val (nlv,nalpha) = newv NONE (lv, alpha)              let val lvi = newv lv
322             val nle = cexp nalpha uvs le              in cexp uvs le;
323         in if impurePO po orelse used nlv                  if impurePO po orelse used lvi then (cpo po; app use vs) else ()
           then F.PRIMOP(cpo po, map use vs, nlv, nle)  
           else nle  
324         end         end
325    
326              | le => buglexp("unexpected lexp", le)) handle x => raise x
327    in
328        cexp
329  end  end
330    
331  (* The code is almost the same for uncounting, except that calling  (* The code is almost the same for uncounting, except that calling
# Line 368  Line 338 
338   * is indeed exactly 1 (accomplished by the "kill" calls) *)   * is indeed exactly 1 (accomplished by the "kill" calls) *)
339  fun unuselexp undertaker = let  fun unuselexp undertaker = let
340      (* val use = if inc then use else unuse *)      (* val use = if inc then use else unuse *)
341      fun uncall lv = unuse undertaker true lv      fun uncall lv = ignore(unuse undertaker true lv)
342      val unuse = fn F.VAR lv => unuse undertaker false lv | _ => ()      val unuse = fn F.VAR lv => ignore(unuse undertaker false lv) | _ => ()
343      val def = use NONE      fun def lv = (use NONE (get lv)) handle x => raise x
344      fun id x = x      fun id x = x
345    
346      fun cpo (NONE:F.dict option,po,lty,tycs) = ()      fun cpo (NONE:F.dict option,po,lty,tycs) = ()
# Line 380  Line 350 
350        | cdcon _ = ()        | cdcon _ = ()
351    
352      fun cfun (f,args,body) = (* census of a fundec *)      fun cfun (f,args,body) = (* census of a fundec *)
353          (app def args; cexp body; app kill args)          (app def args; cexp body; app kill args) handle x => raise x
354    
355      and cexp lexp =      and cexp lexp =
356          case lexp          (case lexp
357           of F.RET vs => app unuse vs           of F.RET vs => app unuse vs
358    
359            | F.LET (lvs,le1,le2) =>            | F.LET (lvs,le1,le2) =>
360              (app def lvs; cexp le2; cexp le1; app kill lvs)              (app def lvs; cexp le2; cexp le1; app kill lvs)
361    
362            | F.FIX (fs,le) =>            | F.FIX (fs,le) =>
363              let val usedfs = (List.filter (used o #2) fs)              let val usedfs = (List.filter ((used o get o #2) handle x => raise x) fs)
364              in app (def o #2) fs;              in app (def o #2) fs;
365                  cexp le;                  cexp le;
366                  app (fn (_,lv,args,le) => cfun(lv, map #1 args, le)) usedfs;                  app (fn (_,lv,args,le) => cfun(lv, map #1 args, le)) usedfs;
# Line 401  Line 371 
371              (uncall f; app unuse vs)              (uncall f; app unuse vs)
372    
373            | F.TFN ((tf,args,body),le) =>            | F.TFN ((tf,args,body),le) =>
374              (if used tf then cexp body else ();              (if used(get tf) then cexp body else ();
375               def tf; cexp le; kill tf)               def tf; cexp le; kill tf)
376    
377            | F.TAPP (F.VAR tf,tycs) => uncall tf            | F.TAPP (F.VAR tf,tycs) => uncall tf
# Line 416  Line 386 
386                   arms)                   arms)
387    
388            | F.CON (dc,_,v,lv,le) =>            | F.CON (dc,_,v,lv,le) =>
389              (cdcon dc; if used lv then unuse v else ();              (cdcon dc; if used(get lv) then unuse v else ();
390               def lv; cexp le; kill lv)               def lv; cexp le; kill lv)
391    
392            | F.RECORD (_,vs,lv,le) =>            | F.RECORD (_,vs,lv,le) =>
393              (if used lv then app unuse vs else ();              (if used(get lv) then app unuse vs else ();
394               def lv; cexp le; kill lv)               def lv; cexp le; kill lv)
395    
396            | F.SELECT (v,_,lv,le) =>            | F.SELECT (v,_,lv,le) =>
397              (if used lv then unuse v else ();              (if used(get lv) then unuse v else ();
398               def lv; cexp le; kill lv)               def lv; cexp le; kill lv)
399    
400            | F.RAISE (v,_) => unuse v            | F.RAISE (v,_) => unuse v
# Line 434  Line 404 
404              (app unuse vs; cpo po; cexp le1; cexp le2)              (app unuse vs; cpo po; cexp le1; cexp le2)
405    
406            | F.PRIMOP (po,vs,lv,le) =>            | F.PRIMOP (po,vs,lv,le) =>
407              (if impurePO po orelse used lv then (cpo po; app unuse vs) else ();              (if impurePO po orelse used(get lv) then
408                     (cpo po; app unuse vs)
409                 else ();
410               def lv; cexp le; kill lv)               def lv; cexp le; kill lv)
411    
412            | le => buglexp("unexpected lexp", le)            | le => buglexp("unexpected lexp", le)) handle x => raise x
413  in  in
414      (cexp, cfun)      (cexp, cfun)
415  end  end
416    
417  fun uselexp le =  val uselexp = census All
     let fun new' call (lv,alpha) = (new call lv; (lv,alpha))  
         fun use' call alpha lv = (use call lv; lv)  
     in census new' use' () All le  
     end  
   
 (*  fun uselexp le = (uselexp' le; ()) *)  
   
418  fun copylexp alpha le =  fun copylexp alpha le =
419      let fun new' call (lv,alpha) =      let val nle = FU.copy alpha le
420              let val nlv = cplv lv      in uselexp nle; nle
             in new call nlv; (nlv, FM.add(alpha, lv, nlv))  
             end  
         fun use' call alpha lv =  
             let val nlv = (FM.lookup alpha lv) handle FM.IntmapF => lv  
             in use call nlv; nlv  
             end  
     in census new' use' alpha All le  
421      end      end
422    
423  fun collect (fdec as (_,f,_,_)) =  fun collect (fdec as (_,f,_,_)) =
424      let val _ = M.clear m               (* start from a fresh state *)      ((*  say "Entering Collect...\n"; *)
425          val nle = uselexp (F.FIX([fdec], F.RET[F.VAR f]))       M.clear m;                         (* start from a fresh state *)
426      in case nle of       PP.LVarString := LVarString;
427          F.FIX([nfdec], F.RET[F.VAR g]) => (ASSERT(f = g, "f = g"); nfdec)       uselexp (F.FIX([fdec], F.RET[F.VAR f]));
428        | _ => bug "not an fdec anymore"       (*  say "...Collect Done.\n"; *)
429      end       fdec)
430    
431  end  end
432  end  end

Legend:
Removed from v.185  
changed lines
  Added in v.186

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