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 163, Thu Oct 29 21:00:27 1998 UTC revision 164, Sat Oct 31 01:03:30 1998 UTC
# Line 6  Line 6 
6    
7      (* Collect information about variables and function uses.      (* Collect information about variables and function uses.
8       * The info is accumulated in the map `m' *)       * The info is accumulated in the map `m' *)
9      val collect : FLINT.fundec -> unit      val collect : FLINT.fundec -> FLINT.fundec
10    
11      (* query functions *)      (* query functions *)
12      val escaping  : FLINT.lvar -> bool  (* non-call uses *)      val escaping  : FLINT.lvar -> bool  (* non-call uses *)
13      val usenb     : FLINT.lvar -> int   (* nb of non-recursive uses *)      val usenb     : FLINT.lvar -> int   (* nb of non-recursive uses *)
14      val called    : FLINT.lvar -> bool  (* known call uses *)      val called    : FLINT.lvar -> bool  (* known call uses *)
15      val insidep   : FLINT.lvar -> bool  (* are we inside f right now ? *)      val actuals   : FLINT.lvar -> (FLINT.value option list) (* constant args *)
     val recursive : FLINT.lvar -> bool  (* self-recursion test *)  
16    
17      (* inc the "true=call,false=use" count *)      (* inc the "true=call,false=use" count *)
18      val use    : bool -> FLINT.lvar -> unit      val use    : FLINT.value list option -> FLINT.lvar -> unit
19      (* dec the "true=call,false=use" count and call the function if zero *)      (* dec the "true=call,false=use" count and call the function if zero *)
20      val unuse  : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> unit      val unuse  : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> unit
21      (* transfer the counts of var1 to var2 *)      (* transfer the counts of var1 to var2 *)
# Line 25  Line 24 
24      val addto  : FLINT.lvar * FLINT.lvar -> unit      val addto  : FLINT.lvar * FLINT.lvar -> unit
25      (* delete the last reference to a variable *)      (* delete the last reference to a variable *)
26      val kill   : FLINT.lvar -> unit      val kill   : FLINT.lvar -> unit
27      (* create a new var entry (true=fun, false=other) initialized to zero *)      (* create a new var entry (SOME arg list if fun) initialized to zero *)
28      val new    : bool -> FLINT.lvar -> unit      val new    : FLINT.lvar list option -> FLINT.lvar -> unit
     (* move all the internal counts to external *)  
     val extcounts : FLINT.lvar -> unit  
29    
30      (* when creating a new var.  Used when alpha-renaming *)      (* when creating a new var.  Used when alpha-renaming *)
31      (* val copy   : FLINT.lvar * FLINT.lvar -> unit *)      (* val copy   : FLINT.lvar * FLINT.lvar -> unit *)
# Line 41  Line 38 
38          ((FLINT.lexp -> unit) *          ((FLINT.lexp -> unit) *
39           ((FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit))           ((FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit))
40      (* function to collect info about a newly created lexp *)      (* function to collect info about a newly created lexp *)
41      val uselexp : FLINT.lexp -> unit   (*     val uselexp : FLINT.lexp -> unit *)
42        (* function to collect info about a newly created lexp *)
43      (* This allows to execute some code and have all the resulting      val copylexp : FLINT.lvar IntmapF.intmap  -> FLINT.lexp -> FLINT.lexp
      * changes made to the internal (for recursion) counters instead  
      * of the external ones. For instance:  
      *     inside f (fn () => call ~1 f)  
      * would decrement the count of recursive function calls of f *)  
     val inside : FLINT.lvar -> (unit -> 'a) -> 'a  
44    
45      (* mostly useful for PPFlint *)      (* mostly useful for PPFlint *)
46      val LVarString : FLINT.lvar -> string      val LVarString : FLINT.lvar -> string
47  end  end
48    
49    (* Internal vs External references:
50     * I started with a version that kept track separately of internal and external
51     * uses.  This has the advantage that if the extuses count goes to zero, we can
52     * consider the function as dead.  Without this, recursive functions can never
53     * be recognized as dead during fcontract (they are still eliminated at the
54     * beginning, tho).  This looks nice at first, but poses problems:
55     * - when you do simple inlining (just moving the body of the procedure), you
56     *   may inadvertently turn ext-uses into int-uses.  This only happens when
57     *   inlining mutually recursive function, but this can be commen (thing of
58     *   when fcontract undoes a useless uncurrying or a recursive function).  This
59     *   can be readily overcome by not using the `move body' optimization in
60     *   dangerous cases and do the full copy+kill instead.
61     * - you have to keep track of what is inside what.  The way I did it was to
62     *   have an 'inside' ref cell in each fun.  That was a bad idea.  The problem
63     *   stems from the fact that when you detect that a function becomes dead,
64     *   you have to somehow reset those `inside' ref cells to reflect the location
65     *   of the function before you can uncount its references.  In most cases, this
66     *   is unnecessary, but it is necessary when undertaking a function mutually
67     *   recursive with a function in which you currently are when you detect the
68     *   function's death.
69     * rather than fix this last point, I decided to get rid of the distinction.
70     * This makes the code simpler and less bug-prone at the cost of slightly
71     * increasing the number of fcontract passes required.
72     *)
73    
74  structure Collect :> COLLECT =  structure Collect :> COLLECT =
75  struct  struct
76  local  local
77      structure F  = FLINT      structure F  = FLINT
78      structure M  = Intmap      structure M  = Intmap
79        structure FM = IntmapF
80      structure LV = LambdaVar      structure LV = LambdaVar
81      structure PP = PPFlint      structure PP = PPFlint
82  in  in
# Line 71  Line 89 
89    | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")    | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
90    
91  datatype info  datatype info
92    (* for functions we keep track of calls and escaping uses    (* for functions we keep track of calls and escaping uses *)
93     * and separately for external and internal (recursive) references *)    = Fun of {calls: int ref, uses: int ref, int: int ref,
94    = Fun of {ecalls: int ref, euses: int ref,              args: (FLINT.lvar * (FLINT.value option)) option list ref}
             inside: bool ref,  
             icalls: int ref, iuses: int ref}  
95    | 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 *)
96    | Transfer of FLINT.lvar      (* for vars who have been transfered *)    | Transfer of FLINT.lvar      (* for vars which have been transfered *)
97    
98  exception NotFound  exception NotFound
99    
# Line 92  Line 108 
108                    raise x;                    raise x;
109                    Var (ref 0)) *)                    Var (ref 0)) *)
110    
111  fun new true lv = M.add m (lv, Fun{ecalls=ref 0, euses=ref 0,  fun new (SOME args) lv =
112                                     inside=ref false,      M.add m (lv, Fun{calls=ref 0, uses=ref 0, int=ref 0,
113                                     icalls=ref 0, iuses=ref 0})                       args=ref (map (fn a => SOME(a, NONE)) args)})
114    | new false lv = M.add m (lv, Var(ref 0))    | 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 {ecalls,euses,icalls,iuses,...} =>         | Fun {calls,uses,...} =>
121           concat           concat ["{", Int.toString (!calls), ",", Int.toString (!uses), "}"]
              ["{(", Int.toString (!ecalls), ",", Int.toString (!euses),  
               "),(", Int.toString (!icalls), ",", Int.toString (!iuses), ")}"]  
122         | Transfer _ => "{-}")         | Transfer _ => "{-}")
123           handle NotFound => "{?}")           handle NotFound => "{?}")
124    
# Line 116  Line 130 
130          of Var uses1 =>          of Var uses1 =>
131             (case info2             (case info2
132               of Var uses2 => uses2 := !uses2 + !uses1               of Var uses2 => uses2 := !uses2 + !uses1
133                | Fun {euses=eu2,inside=i2,iuses=iu2,...} =>                | Fun {uses=uses2,...} => uses2 := !uses2 + !uses1
                 if !i2 then iu2 := !iu2 + !uses1  
                 else eu2 := !eu2 + !uses1  
134                | Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))                | Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))
135           | Fun {inside=i1,euses=eu1,iuses=iu1,ecalls=ec1,icalls=ic1,...} =>           | Fun {uses=uses1,calls=calls1,...} =>
136             (ASSERT(!iu1 + !ic1 = 0 andalso not(!i1), "improper fun transfer");             (case info2
137              case info2               of Fun {uses=uses2,calls=calls2,...} =>
138               of Fun {inside=i2,euses=eu2,iuses=iu2,ecalls=ec2,icalls=ic2,...} =>                  (uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)
139                  if !i2 then (iu2 := !iu2 + !eu1; ic2 := !ic2 + !ec1)                | Var uses2 => uses2 := !uses2 + !uses1
                 else (eu2 := !eu2 + !eu1; ec2 := !ec2 + !ec1)  
               | Var uses => uses := !uses + !eu1  
140                | Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))                | Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))
141           | Transfer _ => bugval("transfering from a Transfer", F.VAR lv1)           | Transfer _ => bugval("transfering from a Transfer", F.VAR lv1)
142      end      end
143  fun transfer (lv1,lv2) =  fun transfer (lv1,lv2) =
144      (addto(lv1, lv2);      (addto(lv1, lv2); M.add m (lv1, Transfer lv2))      (* note the transfer *)
      M.add m (lv1, Transfer lv2))       (* note the transfer *)  
145    
146  fun inc ri = (ri := !ri + 1)  fun inc ri = (ri := !ri + 1)
147  fun dec ri = (ri := !ri - 1)  fun dec ri = (ri := !ri - 1)
148    
149    (* - first list is list of formal args
150     * - second is list of `up to know known arg'
151     * - third is args of the current call. *)
152    fun mergearg (NONE,a) = NONE
153      | mergearg (SOME(fv,NONE),a) =
154        if a = F.VAR fv then SOME(fv,NONE) else SOME(fv,SOME a)
155      | mergearg (SOME(fv,SOME b),a) =
156        if a = b orelse a = F.VAR fv then SOME(fv,SOME b) else NONE
157    
158    fun actuals lv =
159        case get lv
160         of Var _ => bug ("can't query actuals of var "^(LVarString lv))
161          | Transfer lv => actuals lv
162          | Fun{args,...} => map (fn SOME(_,v) => v | _ => NONE) (!args)
163    
164  fun use call lv =  fun use call lv =
165      case get lv      case get lv
166       of Var uses => inc uses       of Var uses => inc uses
       | (Fun {inside=ref true, iuses=uses,icalls=calls,...} |  
          Fun {inside=ref false,euses=uses,ecalls=calls,...} ) =>  
         (if call then inc calls else (); inc uses)  
167        | Transfer lv => use call lv        | Transfer lv => use call lv
168          | Fun {uses,calls,args,...} =>
169            case call of
170                NONE => (inc uses; args := map (fn _ => NONE) (!args))
171              | SOME vals =>
172                (inc calls; inc uses; args := ListPair.map mergearg (!args, vals))
173    
174  fun unuse undertaker call lv =  fun unuse undertaker call lv =
175      let fun check uses =      let fun check uses =
176              if !uses < 0 then              if !uses < 0 then
177                  bugval("decrementing too much", F.VAR lv)                  bugval("decrementing too much", F.VAR lv)
178              else if !uses = 0 then              else if !uses = 0 then
179                  undertaker lv                  (*  if lv = 1294 then bug "here it is !!" else *) undertaker lv
180              else ()              else ()
181      in case get lv      in case get lv
182          of Var uses => (dec uses; check uses)          of Var uses => (dec uses; check uses)
183           | Fun {inside=ref false,euses=uses,ecalls=calls,...} =>           | Fun {uses,calls,...} =>
184             (dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)             (dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)
          | Fun {inside=ref true, iuses=uses,icalls=calls,...} =>  
            (dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown rec-sanity"))  
185           | Transfer lv => unuse undertaker call lv           | Transfer lv => unuse undertaker call lv
186      end      end
187    
188  fun insidep lv =  fun usenb lv     = case get lv of (Fun{uses=uses,...} | Var uses) => !uses
     case get lv  
      of Fun{inside=ref x,...} => x  
       | Var us => false  
       | Transfer lv => (say "\nCollect insidep on transfer"; insidep lv)  
   
 (* move internal counts to external *)  
 fun extcounts lv =  
     case get lv  
      of Fun{iuses,euses,icalls,ecalls,...}  
         => (euses := !euses + !iuses; iuses := 0;  
             ecalls := !ecalls + !icalls; icalls := 0)  
       | Var us => ()  
       | Transfer lv => (say "\nCollect extcounts on transfer"; extcounts lv)  
   
 fun usenb lv     = case get lv of (Fun{euses=uses,...} | Var uses) => !uses  
189                                  | Transfer _ => 0                                  | Transfer _ => 0
190  fun used lv      = usenb lv > 0  fun used lv      = usenb lv > 0
191  fun recursive lv = case get lv of (Fun{iuses=uses,...} | Var uses) => !uses > 0  
                                 | Transfer lv => (say "\nCollect:recursive on transfer"; recursive lv)  
 (* fun callnb lv    = case get lv of Fun{ecalls,...} => !ecalls | Var us => !us *)  
192  fun escaping lv =  fun escaping lv =
193      case get lv      case get lv
194       of Fun{iuses,euses,icalls,ecalls,...}       of Fun{uses,calls,...} => !uses > !calls
         => !euses + !iuses > !ecalls + !icalls  
195        | Var us => !us > 0 (* arbitrary, but I opted for the "safe" choice *)        | Var us => !us > 0 (* arbitrary, but I opted for the "safe" choice *)
196        | Transfer lv => (say "\nCollect escaping on transfer"; escaping lv)        | Transfer lv => (say "\nCollect escaping on transfer"; escaping lv)
197    
198  fun called lv =  fun called lv =
199      case get lv      case get lv
200       of Fun{icalls,ecalls,...} => !ecalls + !icalls > 0       of Fun{calls,...} => !calls > 0
201        | Var us => false (* arbitrary, but consistent with escaping *)        | Var us => false (* arbitrary, but consistent with escaping *)
202        | Transfer lv => (say "\nCollect escaping on transfer"; called lv)        | Transfer lv => (say "\nCollect escaping on transfer"; called lv)
203    
 (* census of the internal part *)  
 fun inside f thunk =  
     case get f  
      of Fun{inside=inside as ref false,...} =>  
         (inside := true; thunk() before inside := false)  
       | Fun _ => (say "\nalready inside "; PP.printSval(F.VAR f); thunk())  
       | _ => bugval("trying to get inside a non-function", F.VAR f)  
   
204  (* 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
205   * conservative when keeping the counts uptodate *)   * conservative when keeping the counts uptodate *)
206  fun kill lv = (ASSERT(usenb lv >= 1, concat ["usenb lv >= 1 ", !PP.LVarString lv]); M.rmv m lv)  fun kill lv = (ASSERT(usenb lv >= 1, concat ["usenb lv >= 1 ", !PP.LVarString lv]); M.rmv m lv)
207    
208  fun census new use = let  (* ********************************************************************** *)
209      (* val use = if inc then use else unuse *)  (* ********************************************************************** *)
210      fun call lv = use true lv  
211      val use = fn F.VAR lv => use false lv | _ => ()  datatype usage
212      val newv = new false    = All
213      val newf = new true    | None
214      fun id x = x    | Some of bool list
215    
216    fun usage bs =
217        let fun ua [] = All
218              | ua (false::_) = Some bs
219              | ua (true::bs) = ua bs
220            fun un [] = None
221              | un (true::_) = Some bs
222              | un (false::bs) = un bs
223        in case bs
224            of true::bs => ua bs
225             | false::bs => un bs
226             | [] => None
227        end
228    
229    val cplv = LambdaVar.dupLvar
230    
231      fun impurePO po = true              (* if a PrimOP is pure or not *)      fun impurePO po = true              (* if a PrimOP is pure or not *)
232    
233      (* here, the use resembles a call, but it's safer to consider it as a use *)  fun census newv substvar alpha uvs le = let
234      fun cpo (NONE:F.dict option,po,lty,tycs) = ()      val cexp = census newv substvar
235        | cpo (SOME{default,table},po,lty,tycs) =      val usevar = substvar NONE alpha
236          (use (F.VAR default); app (use o F.VAR o #2) table)      fun callvar args lv = substvar (SOME args) alpha lv
237      fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = use (F.VAR lv)      fun use (F.VAR lv) = F.VAR(usevar lv) | use v = v
238        | cdcon _ = ()      fun call args (F.VAR lv) = F.VAR(callvar args lv) | call _ v = v
239        fun newvs (lvs,alpha) =
240            foldr (fn (lv,(lvs,alpha)) =>
241                   let val (nlv,nalpha) = newv NONE (lv,alpha)
242                   in (nlv::lvs, nalpha) end)
243                  ([],alpha) lvs
244        fun newfs (fdecs,alpha) =
245            foldr (fn ((_,lv,args,_):F.fundec,(lvs,alpha)) =>
246                   let val (nlv,nalpha) = newv (SOME(map #1 args)) (lv,alpha)
247                   in (nlv::lvs, nalpha) end)
248                  ([],alpha) fdecs
249        fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
250            (s, Access.EXN(Access.LVAR(usevar lv)), lty)
251          | cdcon dc = dc
252        fun cpo (SOME{default,table},po,lty,tycs) =
253            (SOME{default=usevar default,
254                  table=map (fn (tycs,lv) => (tycs, usevar lv)) table},
255             po,lty,tycs)
256          | cpo po = po
257    in case le
258        of F.RET vs => F.RET(map use vs)
259    
260         | F.LET (lvs,le,body) =>
261           let val (nlvs,nalpha) = newvs (lvs,alpha)
262               val nbody = cexp nalpha uvs body
263               val nuvs = usage(map used nlvs)
264               val nle = cexp alpha nuvs le
265           in F.LET(nlvs, nle, nbody)
266           end
267    
268      (* the actual function:       | F.FIX (fdecs,le) =>
269       * `uvs' is an optional list of booleans representing which of         let val (nfs, nalpha) = newfs(fdecs, alpha)
      * the return values are actually used *)  
     fun cexp uvs lexp =  
         case lexp  
          of F.RET vs => app use vs  
 (*          (case uvs *)  
 (*            of SOME uvs => (* only count vals that are actually used *) *)  
 (*               app (fn(v,uv)=>if uv then use v else ()) (ListPair.zip(vs,uvs)) *)  
 (*             | NONE => app use vs) *)  
270    
271            | F.LET (lvs,le1,le2) =>             (* census of a function *)
272              (app newv lvs; cexp uvs le2; cexp (SOME(map used lvs)) le1)             fun cfun ((fk,f,args,body):F.fundec,nf) =
273                   let val (nargs,ialpha) = newvs(map #1 args, nalpha)
274                       val nbody = cexp ialpha All body
275                   in (fk, nf, ListPair.zip(nargs, (map #2 args)), nbody)
276                   end
277    
278            | F.FIX (fs,le) =>             (* some sort of tracing GC on functions *)
279              let fun cfun ((_,f,args,body):F.fundec) = (* census of a fundec *)             fun cfix fs = let
                     (app (newv o #1) args; inside f (fn()=> cexp NONE body))  
                 fun cfix fs = let       (* census of a list of fundecs *)  
280                      val (ufs,nfs) = List.partition (used o #2) fs                      val (ufs,nfs) = List.partition (used o #2) fs
281                  in if List.null ufs then ()             in if List.null ufs then []
282                     else (app cfun ufs; cfix nfs)                else (map cfun ufs) @ (cfix nfs)
283                  end                  end
284              in app (newf o #2) fs; cexp uvs le; cfix fs  
285               val nle = cexp nalpha uvs le
286               val nfdecs = cfix(ListPair.zip(fdecs, nfs))
287           in
288               if List.null nfdecs then nle else F.FIX(nfdecs, nle)
289              end              end
290    
291            | F.APP (F.VAR f,vs) =>       | F.APP (f,args) => F.APP(call args f, map use args)
             (call f; app use vs)  
292    
293            | F.TFN ((tf,args,body),le) =>       | F.TFN ((lv,args,body),le) =>
294              (newf tf; cexp uvs le;         (* don't forget to rename the tvar also *)
295               if used tf then inside tf (fn()=> cexp NONE body) else ())         let val (nlv,nalpha) = newv (SOME[]) (lv,alpha)
296               val nle = cexp nalpha uvs le
297           in
298               if used nlv then
299                   let val (nargs,ialpha) = newvs(map #1 args, alpha)
300                       val nbody = cexp ialpha All body
301                   in F.TFN((nlv, ListPair.zip(nargs, map #2 args), nbody), nle)
302                   end
303               else
304                   nle
305           end
306    
307            | F.TAPP (F.VAR tf,tycs) => call tf       | F.TAPP (f,tycs) => F.TAPP(call [] f, tycs)
308    
309            | F.SWITCH (v,cs,arms,def) =>       | F.SWITCH (v,ac,arms,def) =>
310              (use v; Option.map (cexp uvs) def;         let fun carm (F.DATAcon(dc,tycs,lv),le) =
311               (* here we don't absolutely have to keep track of vars bound within                 let val (nlv,nalpha) = newv NONE (lv, alpha)
312                * each arm since these vars can't be eliminated anyway *)                 in (F.DATAcon(cdcon dc, tycs, nlv), cexp nalpha uvs le)
313               app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp uvs le)                 end
314                     | (_,le) => cexp uvs le)               | carm (con,le) = (con, cexp alpha uvs le)
315                   arms)         in F.SWITCH(use v, ac, map carm arms, Option.map (cexp alpha uvs) def)
316           end
317    
318            | F.CON (dc,_,v,lv,le) =>       | F.CON (dc,tycs,v,lv,le) =>
319              (cdcon dc; newv lv; cexp uvs le; if used lv then use v else ())         let val (nlv,nalpha) = newv NONE (lv, alpha)
320               val nle = cexp nalpha uvs le
321           in if used nlv
322              then F.CON(cdcon dc, tycs, use v, nlv, nle)
323              else nle
324           end
325    
326            | F.RECORD (_,vs,lv,le) =>       | F.RECORD (rk,vs,lv,le) =>
327              (newv lv; cexp uvs le; if used lv then app use vs else ())         let val (nlv,nalpha) = newv NONE (lv, alpha)
328               val nle = cexp nalpha uvs le
329           in if used nlv
330              then F.RECORD(rk, map use vs, nlv, nle)
331              else nle
332           end
333    
334            | F.SELECT (v,_,lv,le) =>       | F.SELECT (v,i,lv,le) =>
335              (newv lv; cexp uvs le; if used lv then use v else ())         let val (nlv,nalpha) = newv NONE (lv, alpha)
336               val nle = cexp nalpha uvs le
337           in if used nlv
338              then F.SELECT(use v, i, nlv, nle)
339              else nle
340           end
341    
342            | F.RAISE (v,_) => use v       | F.RAISE (v,ltys) => F.RAISE(use v, ltys)
343            | F.HANDLE (le,v) => (use v; cexp uvs le)  
344         | F.HANDLE (le,v) => F.HANDLE(cexp alpha uvs le, use v)
345    
346            | F.BRANCH (po,vs,le1,le2) =>            | F.BRANCH (po,vs,le1,le2) =>
347              (app use vs; cpo po; cexp uvs le1; cexp uvs le2)         F.BRANCH(cpo po, map use vs, cexp alpha uvs le1, cexp alpha uvs le2)
348    
349            | F.PRIMOP (po,vs,lv,le) =>            | F.PRIMOP (po,vs,lv,le) =>
350              (newv lv; cexp uvs le;         let val (nlv,nalpha) = newv NONE (lv, alpha)
351               if impurePO po orelse used lv then (cpo po; app use vs) else ())             val nle = cexp nalpha uvs le
352           in if impurePO po orelse used nlv
353            | le => buglexp("unexpected lexp", le)            then F.PRIMOP(cpo po, map use vs, nlv, nle)
354  in            else nle
355      cexp         end
356  end  end
357    
358  (* The code is almost the same for uncounting, except that calling  (* The code is almost the same for uncounting, except that calling
# Line 302  Line 367 
367      (* val use = if inc then use else unuse *)      (* val use = if inc then use else unuse *)
368      fun uncall lv = unuse undertaker true lv      fun uncall lv = unuse undertaker true lv
369      val unuse = fn F.VAR lv => unuse undertaker false lv | _ => ()      val unuse = fn F.VAR lv => unuse undertaker false lv | _ => ()
370      val def = use false      val def = use NONE
371      fun id x = x      fun id x = x
372    
     fun impurePO po = true              (* if a PrimOP is pure or not *)  
   
373      fun cpo (NONE:F.dict option,po,lty,tycs) = ()      fun cpo (NONE:F.dict option,po,lty,tycs) = ()
374        | cpo (SOME{default,table},po,lty,tycs) =        | cpo (SOME{default,table},po,lty,tycs) =
375          (unuse(F.VAR default); app (unuse o F.VAR o #2) table)          (unuse(F.VAR default); app (unuse o F.VAR o #2) table)
# Line 314  Line 377 
377        | cdcon _ = ()        | cdcon _ = ()
378    
379      fun cfun (f,args,body) = (* census of a fundec *)      fun cfun (f,args,body) = (* census of a fundec *)
380          (app def args;          (app def args; cexp body; app kill args)
          inside f (fn()=> cexp body);  
          app kill args)  
381    
382      and cexp lexp =      and cexp lexp =
383          case lexp          case lexp
# Line 337  Line 398 
398              (uncall f; app unuse vs)              (uncall f; app unuse vs)
399    
400            | F.TFN ((tf,args,body),le) =>            | F.TFN ((tf,args,body),le) =>
401              (if used tf then inside tf (fn()=> cexp body) else ();              (if used tf then cexp body else ();
402               def tf; cexp le; kill tf)               def tf; cexp le; kill tf)
403    
404            | F.TAPP (F.VAR tf,tycs) => uncall tf            | F.TAPP (F.VAR tf,tycs) => uncall tf
# Line 378  Line 439 
439      (cexp, cfun)      (cexp, cfun)
440  end  end
441    
442  val uselexp = census new use NONE  fun uselexp le =
443        let fun new' call (lv,alpha) = (new call lv; (lv,alpha))
444            fun use' call alpha lv = (use call lv; lv)
445        in census new' use' () All le
446        end
447    
448    (*  fun uselexp le = (uselexp' le; ()) *)
449    
450    fun copylexp alpha le =
451        let fun new' call (lv,alpha) =
452                let val nlv = cplv lv
453                in new call nlv; (nlv, FM.add(alpha, lv, nlv))
454                end
455            fun use' call alpha lv =
456                let val nlv = (FM.lookup alpha lv) handle FM.IntmapF => lv
457                in use call nlv; nlv
458                end
459        in census new' use' alpha All le
460        end
461    
462  fun collect (fdec as (_,f,_,_)) =  fun collect (fdec as (_,f,_,_)) =
463      (M.clear m;                         (* start from a fresh state *)      let val _ = M.clear m               (* start from a fresh state *)
464       uselexp (F.FIX([fdec], F.RET[F.VAR f])))          val nle = uselexp (F.FIX([fdec], F.RET[F.VAR f]))
465        in case nle of
466            F.FIX([nfdec], F.RET[F.VAR g]) => (ASSERT(f = g, "f = g"); nfdec)
467          | _ => bug "not an fdec anymore"
468        end
469    
470  end  end
471  end  end

Legend:
Removed from v.163  
changed lines
  Added in v.164

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