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 81, Sat May 2 23:59:45 1998 UTC revision 82, Sun May 3 00:00:24 1998 UTC
# Line 13  Line 13 
13      val usenb     : FLINT.lvar -> int   (* nb of non-recursive uses *)      val usenb     : FLINT.lvar -> int   (* nb of non-recursive uses *)
14      (* val callnb    : FLINT.lvar -> int *)      (* val callnb    : FLINT.lvar -> int *)
15    
     (* fix up function to keep counts up-to-date *)  
     val unuselexp : (FLINT.lvar -> unit) -> FLINT.lexp -> unit  
   
16      (* inc the "true=call,false=use" count *)      (* inc the "true=call,false=use" count *)
17      val use    : bool -> FLINT.lvar -> unit      val use    : bool -> FLINT.lvar -> unit
18      (* 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 *)
19      val unuse  : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> unit      val unuse  : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> unit
20      (* transfer the counts of var1 to var2 *)      (* transfer the counts of var1 to var2 *)
21      val transfer : FLINT.lvar * FLINT.lvar -> unit      val transfer : FLINT.lvar * FLINT.lvar -> unit
22        (* add the counts of var1 to var2 *)
23        val addto  : FLINT.lvar * FLINT.lvar -> unit
24        (* delete the last reference to a variable *)
25        val kill   : FLINT.lvar -> unit
26        (* create a new var entry (true=fun, false=other) initialized to zero *)
27        val new    : bool -> FLINT.lvar -> unit
28    
29        (* when creating a new var.  Used when alpha-renaming *)
30        (* val copy   : FLINT.lvar * FLINT.lvar -> unit *)
31    
32        (* fix up function to keep counts up-to-date when getting rid of a function.
33         * the fun arg is only called for free variables becoming dead. *)
34        val unusefdec : (FLINT.lvar -> unit) -> (FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit
35        (* function to collect info about a newly created lexp *)
36        val uselexp : FLINT.lexp -> unit
37    
38      (* This allows to execute some code and have all the resulting      (* This allows to execute some code and have all the resulting
39       * changes made to the internal (for recursion) counters instead       * changes made to the internal (for recursion) counters instead
# Line 58  Line 70 
70              inside: bool ref,              inside: bool ref,
71              icalls: int ref, iuses: int ref}              icalls: int ref, iuses: int ref}
72    | 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 *)
73      | Transfer of FLINT.lvar      (* for vars who have been transfered *)
74    
75  exception NotFound  exception NotFound
76    
77  val m : info Intmap.intmap = M.new(128, NotFound)  val m : info M.intmap = M.new(128, NotFound)
78    
79  (* map related helper functions *)  (* map related helper functions *)
80  val get = M.map m  fun get lv = (M.map m lv)
81                     (* handle x as NotFound =>
82                     (say "\nCollect:get unknown var ";
83                      PP.printSval (F.VAR lv);
84                      say ". Assuming dead...";
85                      raise x;
86                      Var (ref 0)) *)
87    
88  fun new true lv = M.add m (lv, Fun{ecalls=ref 0, euses=ref 0,  fun new true lv = M.add m (lv, Fun{ecalls=ref 0, euses=ref 0,
89                                     inside=ref false,                                     inside=ref false,
90                                     icalls=ref 0, iuses=ref 0})                                     icalls=ref 0, iuses=ref 0})
# Line 77  Line 97 
97         | Fun {ecalls,euses,icalls,iuses,...} =>         | Fun {ecalls,euses,icalls,iuses,...} =>
98           concat           concat
99               ["{(", Int.toString (!ecalls), ",", Int.toString (!euses),               ["{(", Int.toString (!ecalls), ",", Int.toString (!euses),
100                "),(", Int.toString (!icalls), ",", Int.toString (!iuses), ")}"])                "),(", Int.toString (!icalls), ",", Int.toString (!iuses), ")}"]
101           | Transfer _ => "{-}")
102           handle NotFound => "{?}")           handle NotFound => "{?}")
103    
104  fun transfer (lv1,lv2) =  (* adds the counts of lv1 to those of lv2 *)
105      case get lv1  fun addto (lv1,lv2) =
106        let val info2 = get lv2
107            val info1 = get lv1
108        in case info1
109       of Var uses1 =>       of Var uses1 =>
110          (case get lv2             (case info2
111            of (Var uses2 | Fun {euses=uses2,...}) =>               of Var uses2 => uses2 := !uses2 + !uses1
112               (uses2 := !uses2 + !uses1; uses1 := 0))                | Fun {euses=eu2,inside=i2,iuses=iu2,...} =>
113                    if !i2 then iu2 := !iu2 + !uses1
114                    else eu2 := !eu2 + !uses1
115                  | Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))
116        | Fun {inside=i1,euses=eu1,iuses=iu1,ecalls=ec1,icalls=ic1,...} =>        | Fun {inside=i1,euses=eu1,iuses=iu1,ecalls=ec1,icalls=ic1,...} =>
117          (ASSERT(!iu1 + !ic1 = 0 andalso not(!i1), "improper fun transfer");          (ASSERT(!iu1 + !ic1 = 0 andalso not(!i1), "improper fun transfer");
118           case get lv2              case info2
119            of Fun {inside=i2,euses=eu2,iuses=iu2,ecalls=ec2,icalls=ic2,...} =>            of Fun {inside=i2,euses=eu2,iuses=iu2,ecalls=ec2,icalls=ic2,...} =>
120               if !i2 then                  if !i2 then (iu2 := !iu2 + !eu1; ic2 := !ic2 + !ec1)
121                   (iu2 := !iu2 + !eu1; eu1 := 0;                  else (eu2 := !eu2 + !eu1; ec2 := !ec2 + !ec1)
122                    ic2 := !ic2 + !ec1; ec1 := 0)                | Var uses => uses := !uses + !eu1
123               else                | Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))
124                   (eu2 := !eu2 + !eu1; eu1 := 0;           | Transfer _ => bugval("transfering from a Transfer", F.VAR lv1)
125                    ec2 := !ec2 + !ec1; ec1 := 0)      end
126             | Var uses =>  fun transfer (lv1,lv2) =
127               (uses := !uses + !eu1;      (addto(lv1, lv2);
128                eu1 := 0; ec1 := 0))       M.add m (lv1, Transfer lv2))       (* note the transfer *)
129    
130  fun inc ri = (ri := !ri + 1)  fun inc ri = (ri := !ri + 1)
131  fun dec ri = (ri := !ri - 1)  fun dec ri = (ri := !ri - 1)
132    
133  fun use call lv =  fun use call lv =
134      inc (case get lv      case get lv
135            of Var uses => uses       of Var uses => inc uses
136             | (Fun {inside=ref true, iuses=uses,icalls=calls,...} |             | (Fun {inside=ref true, iuses=uses,icalls=calls,...} |
137                Fun {inside=ref false,euses=uses,ecalls=calls,...}) =>                Fun {inside=ref false,euses=uses,ecalls=calls,...}) =>
138               (if call then inc calls else (); uses))          (if call then inc calls else (); inc uses)
139          | Transfer lv => use call lv
140    
141  fun unuse undertaker call lv =  fun unuse undertaker call lv =
142      let fun check uses =      let fun check uses =
# Line 120  Line 148 
148      in case get lv      in case get lv
149          of Var uses => (dec uses; check uses)          of Var uses => (dec uses; check uses)
150           | Fun {inside=ref false,euses=uses,ecalls=calls,...} =>           | Fun {inside=ref false,euses=uses,ecalls=calls,...} =>
151             (if call then dec calls else (); dec uses; check uses)             (dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)
152           | Fun {inside=ref true, iuses=uses,icalls=calls,...} =>           | Fun {inside=ref true, iuses=uses,icalls=calls,...} =>
153             (if call then dec calls else (); dec uses)             (dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown rec-sanity"))
154             | Transfer lv => unuse undertaker call lv
155      end      end
156    
157  fun usenb lv     = case get lv of (Fun{euses=uses,...} | Var uses) => !uses  fun usenb lv     = case get lv of (Fun{euses=uses,...} | Var uses) => !uses
158                                    | Transfer _ => 0
159  fun used lv      = usenb lv > 0  fun used lv      = usenb lv > 0
160  fun recursive lv = case get lv of (Fun{iuses=uses,...} | Var uses) => !uses > 0  fun recursive lv = case get lv of (Fun{iuses=uses,...} | Var uses) => !uses > 0
161                                    | Transfer lv => (say "\nCollect:recursive on transfer"; recursive lv)
162  (* fun callnb lv    = case get lv of Fun{ecalls,...} => !ecalls | Var us => !us *)  (* fun callnb lv    = case get lv of Fun{ecalls,...} => !ecalls | Var us => !us *)
163  fun escaping lv =  fun escaping lv =
164      case get lv      case get lv
165       of Fun{iuses,euses,icalls,ecalls,...}       of Fun{iuses,euses,icalls,ecalls,...}
166          => !euses + !iuses > !ecalls + !icalls          => !euses + !iuses > !ecalls + !icalls
167        | Var us => !us > 0 (* arbitrary, but I opted for the "safe" choice *)        | Var us => !us > 0 (* arbitrary, but I opted for the "safe" choice *)
168          | Transfer lv => (say "\nCollect escaping on transfer"; escaping lv)
169    
170  (* census of the internal part *)  (* census of the internal part *)
171  fun inside f thunk =  fun inside f thunk =
# Line 143  Line 175 
175        | Fun _ => (say "\nalready inside "; PP.printSval(F.VAR f); thunk())        | Fun _ => (say "\nalready inside "; PP.printSval(F.VAR f); thunk())
176        | _ => bugval("trying to get inside a non-function", F.VAR f)        | _ => bugval("trying to get inside a non-function", F.VAR f)
177    
178    (* Ideally, we should check that usenb = 1, but we may have been a bit
179     * conservative when keeping the counts uptodate *)
180    fun kill lv = (ASSERT(usenb lv >= 1, concat ["usenb lv >= 1 ", !PP.LVarString lv]); M.rmv m lv)
181    
182  fun census new use = let  fun census new use = let
183      (* val use = if inc then use else unuse *)      (* val use = if inc then use else unuse *)
184      fun call lv = use true lv      fun call lv = use true lv
# Line 153  Line 189 
189    
190      fun impurePO po = true              (* if a PrimOP is pure or not *)      fun impurePO po = true              (* if a PrimOP is pure or not *)
191    
192        (* here, the use resembles a call, but it's safer to consider it as a use *)
193      fun cpo (NONE:F.dict option,po,lty,tycs) = ()      fun cpo (NONE:F.dict option,po,lty,tycs) = ()
194        | cpo (SOME{default,table},po,lty,tycs) =        | cpo (SOME{default,table},po,lty,tycs) =
195          (call default; app (call o #2) table)          (use (F.VAR default); app (use o F.VAR o #2) table)
196        fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = use (F.VAR lv)
     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = call lv  
197        | cdcon _ = ()        | cdcon _ = ()
198    
199      (* the actual function:      (* the actual function:
# Line 226  Line 262 
262      cexp      cexp
263  end  end
264    
265  (* fun update 1 lexp    = census (fn _ => fn _ =>()) use NONE lexp *)  (* The code is almost the same for uncounting, except that calling
266  (*   | update (~1) lexp = census (fn _ => fn _ =>()) unuse NONE lexp *)   * undertaker should not be done for non-free variables.  For that we
267  (*   | update _ lexp = bug ("non-unary update", lexp) *)   * artificially increase the usage count of each variable when it's defined
268     * (accomplished via the "def" calls)
269     * so that its counter never reaches 0 while processing its scope.
270     * Once its scope has been processed, we can completely get rid of
271     * the variable and corresponding info (after verifying that the count
272     * is indeed exactly 1 (accomplished by the "kill" calls) *)
273    fun unusefdec undertaker = let
274        (* val use = if inc then use else unuse *)
275        fun uncall lv = unuse undertaker true lv
276        val unuse = fn F.VAR lv => unuse undertaker false lv | _ => ()
277        val def = use false
278        fun id x = x
279    
280        fun impurePO po = true              (* if a PrimOP is pure or not *)
281    
282        fun cpo (NONE:F.dict option,po,lty,tycs) = ()
283          | cpo (SOME{default,table},po,lty,tycs) =
284            (unuse(F.VAR default); app (unuse o F.VAR o #2) table)
285        fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = unuse(F.VAR lv)
286          | cdcon _ = ()
287    
288        fun cfun (f,args,body) = (* census of a fundec *)
289            (app def args;
290             inside f (fn()=> cexp body);
291             app kill args)
292    
293        and cexp lexp =
294            case lexp
295             of F.RET vs => app unuse vs
296    
297              | F.LET (lvs,le1,le2) =>
298                (app def lvs; cexp le2; cexp le1; app kill lvs)
299    
300              | F.FIX (fs,le) =>
301                let val usedfs = (List.filter (used o #2) fs)
302                in app (def o #2) fs;
303                    cexp le;
304                    app (fn (_,lv,args,le) => cfun(lv, map #1 args, le)) usedfs;
305                    app (kill o #2) fs
306                end
307    
308              | F.APP (F.VAR f,vs) =>
309                (uncall f; app unuse vs)
310    
311              | F.TFN ((tf,args,body),le) =>
312                (if used tf then inside tf (fn()=> cexp body) else ();
313                 def tf; cexp le; kill tf)
314    
315              | F.TAPP (F.VAR tf,tycs) => uncall tf
316    
317              | F.SWITCH (v,cs,arms,default) =>
318                (unuse v; Option.map cexp default;
319                 (* here we don't absolutely have to keep track of vars bound within
320                  * each arm since these vars can't be eliminated anyway *)
321                 app (fn (F.DATAcon(dc,_,lv),le) =>
322                      (cdcon dc; def lv; cexp le; kill lv)
323                       | (_,le) => cexp le)
324                     arms)
325    
326              | F.CON (dc,_,v,lv,le) =>
327                (cdcon dc; if used lv then unuse v else ();
328                 def lv; cexp le; kill lv)
329    
330              | F.RECORD (_,vs,lv,le) =>
331                (if used lv then app unuse vs else ();
332                 def lv; cexp le; kill lv)
333    
334              | F.SELECT (v,_,lv,le) =>
335                (if used lv then unuse v else ();
336                 def lv; cexp le; kill lv)
337    
338              | F.RAISE (v,_) => unuse v
339              | F.HANDLE (le,v) => (unuse v; cexp le)
340    
341              | F.BRANCH (po,vs,le1,le2) =>
342                (app unuse vs; cpo po; cexp le1; cexp le2)
343    
344              | F.PRIMOP (po,vs,lv,le) =>
345                (if impurePO po orelse used lv then (cpo po; app unuse vs) else ();
346                 def lv; cexp le; kill lv)
347    
348              | le => buglexp("unexpected lexp", le)
349    in
350        cfun
351    end
352    
353  fun unuselexp undertaker lexp =  val uselexp = census new use NONE
     census (fn _ => fn _ =>()) (unuse undertaker) NONE lexp  
354    
355  fun collect (fdec as (_,f,_,_)) =  fun collect (fdec as (_,f,_,_)) =
356      (M.clear m;         (* start from a fresh state *)      (M.clear m;         (* start from a fresh state *)
357       census new use NONE (F.FIX([fdec], F.RET[F.VAR f])))       uselexp (F.FIX([fdec], F.RET[F.VAR f])))
358    
359  end  end
360  end  end

Legend:
Removed from v.81  
changed lines
  Added in v.82

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