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 188, Thu Nov 12 00:24:58 1998 UTC revision 189, Sun Nov 15 22:29:42 1998 UTC
# Line 14  Line 14 
14      (* query functions *)      (* query functions *)
15      val escaping  : info -> bool        (* non-call uses *)      val escaping  : info -> bool        (* non-call uses *)
16      val called    : info -> bool        (* known call uses *)      val called    : info -> bool        (* known call uses *)
17      val usenb     : info -> int (* nb of non-recursive uses *)      val dead      : info -> bool        (* usenb = 0 ? *)
18        val usenb     : info -> int         (* total nb of uses *)
19      val actuals   : info -> (FLINT.value option list) (* constant args *)      val actuals   : info -> (FLINT.value option list) (* constant args *)
20    
21        (* self-referential (i.e. internal) uses *)
22        val iusenb    : info -> int
23        val icallnb   : info -> int
24        (* reset to safe values (0 and 0) *)
25        val ireset    : info -> unit
26    
27      (* inc the "true=call,false=use" count *)      (* inc the "true=call,false=use" count *)
28      val use    : FLINT.value list option -> info -> unit      val use    : FLINT.value list option -> info -> unit
29      (* dec the "true=call,false=use" count and return true if zero *)      (* dec the "true=call,false=use" count and return true if zero *)
# Line 53  Line 60 
60   * beginning, tho).  This looks nice at first, but poses problems:   * beginning, tho).  This looks nice at first, but poses problems:
61   * - when you do simple inlining (just moving the body of the procedure), you   * - when you do simple inlining (just moving the body of the procedure), you
62   *   may inadvertently turn ext-uses into int-uses.  This only happens when   *   may inadvertently turn ext-uses into int-uses.  This only happens when
63   *   inlining mutually recursive function, but this can be commen (thing of   *   inlining mutually recursive function, but this can be commen (think of
64   *   when fcontract undoes a useless uncurrying or a recursive function).  This   *   when fcontract undoes a useless uncurrying of a recursive function).  This
65   *   can be readily overcome by not using the `move body' optimization in   *   can be readily overcome by not using the `move body' optimization in
66   *   dangerous cases and do the full copy+kill instead.   *   dangerous cases and do the full copy+kill instead.
67   * - you have to keep track of what is inside what.  The way I did it was to   * - you have to keep track of what is inside what.  The way I did it was to
# Line 65  Line 72 
72   *   is unnecessary, but it is necessary when undertaking a function mutually   *   is unnecessary, but it is necessary when undertaking a function mutually
73   *   recursive with a function in which you currently are when you detect the   *   recursive with a function in which you currently are when you detect the
74   *   function's death.   *   function's death.
75   * rather than fix this last point, I decided to get rid of the distinction.   * rather than fix this last point, I decided to give up on keeping internal
76   * This makes the code simpler and less bug-prone at the cost of slightly   * counts up-to-date.  Instead, I just compute them once during collect and
77   * increasing the number of fcontract passes required.   * never touch them again:  this means that they should not be relied on in
78     * general.  More specifically, they become potentially invalid as soon as
79     * the body of the function is changed.  This still allows their use in
80     * many cases.
81   *)   *)
82    
83  structure Collect :> COLLECT =  structure Collect :> COLLECT =
# Line 87  Line 97 
97  fun ASSERT (true,_) = ()  fun ASSERT (true,_) = ()
98    | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")    | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
99    
100  type info  datatype info
101    (* we keep track of calls and escaping uses *)    (* we keep track of calls and escaping uses *)
102    = {calls: int ref, uses: int ref,    = Info of {calls: int ref, uses: int ref, int: (int * int) ref,
103       args: (FLINT.lvar * (FLINT.value option)) option list ref option}       args: (FLINT.lvar * (FLINT.value option)) option list ref option}
104    
105  exception NotFound  exception NotFound
106    
107  val m : info M.intmap = M.new(128, NotFound)  val m : info M.intmap = M.new(128, NotFound)
108    
109    fun new args lv =
110        let val i = Info{uses=ref 0, calls=ref 0, int=ref(0,0),
111                         args=case args
112                               of SOME args =>
113                                  SOME(ref(map (fn a => SOME(a, NONE)) args))
114                                | NONE => NONE}
115        in M.add m (lv, i); i
116        end
117    
118  (* map related helper functions *)  (* map related helper functions *)
119  fun get lv = (M.map m lv)  fun get lv = (M.map m lv)
120                    handle x as NotFound =>                    handle x as NotFound =>
# Line 103  Line 122 
122                          (LV.lvarName lv)^                          (LV.lvarName lv)^
123                          ". Pretending dead...\n");                          ". Pretending dead...\n");
124                     (*  raise x; *)                     (*  raise x; *)
125                     {uses=ref 0, calls=ref 0, args=NONE})                     new NONE lv)
126    
127  fun LVarString lv =  fun LVarString lv =
128      let val {uses=ref uses,calls=ref calls,...} = get lv      let val Info{uses=ref uses,calls=ref calls,...} = get lv
129      in (LV.lvarName lv)^      in (LV.lvarName lv)^
130          "{"^(Int.toString uses)^          "{"^(Int.toString uses)^
131          (if calls > 0 then ","^(Int.toString calls) else "")^"}"          (if calls > 0 then ","^(Int.toString calls) else "")^"}"
132      end      end
133    
 fun new args lv =  
     let val i = {uses=ref 0, calls=ref 0,  
                  args=case args  
                        of SOME args => SOME(ref(map (fn a => SOME(a, NONE)) args))  
                         | NONE => NONE}  
     in M.add m (lv, i); i  
     end  
   
134  (* adds the counts of lv1 to those of lv2 *)  (* adds the counts of lv1 to those of lv2 *)
135  fun addto ({uses=uses1,calls=calls1,...}:info,{uses=uses2,calls=calls2,...}:info) =  fun addto (Info{uses=uses1,calls=calls1,...},Info{uses=uses2,calls=calls2,...}) =
136      (uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)      (uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)
137    
138  fun transfer (lv1,lv2) =  fun transfer (lv1,lv2) =
# Line 144  Line 155 
155    | mergearg (SOME(fv,SOME b),a) =    | mergearg (SOME(fv,SOME b),a) =
156      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
157    
158  fun actuals ({args=NONE,...}:info) = bug "can't query actuals of a var"  fun actuals (Info{args=NONE,...}) = bug "no actuals (maybe a var?)"
159    | actuals {args=SOME args,...} = map (fn SOME(_,v) => v | _ => NONE) (!args)    | actuals (Info{args=SOME args,...}) = map (fn SOME(_,v) => v | _ => NONE) (!args)
160    
161  fun use call ({uses,calls,args,...}:info) =  fun use call (Info{uses,calls,args,...}) =
162      (inc uses;      (inc uses;
163       case call       case call
164        of NONE => (case args of SOME args => args := map (fn _ => NONE) (!args)        of NONE => (case args of SOME args => args := map (fn _ => NONE) (!args)
# Line 157  Line 168 
168           case args of SOME args => args := ListPair.map mergearg (!args, vals)           case args of SOME args => args := ListPair.map mergearg (!args, vals)
169                      | _ => ()))                      | _ => ()))
170    
171  fun unuse call ({uses,calls,...}:info) =  fun unuse call (Info{uses,calls,...}) =
172      (* notice the calls could be dec'd to negative values because a      (* notice the calls could be dec'd to negative values because a
173       * use might be turned from escaping to known between the census       * use might be turned from escaping to known between the census
174       * and the unuse.  We can't easily detect such changes, but       * and the unuse.  We can't easily detect such changes, but
175       * we can detect it happened when we try to go below zero. *)       * we can detect it happened when we try to go below zero. *)
176      (dec uses;      (dec uses;
177       if (call andalso !calls > 0) then dec calls       if (call (*  andalso !calls > 0 *)) then dec calls
178       else ASSERT(!uses >= !calls, "unknown sanity");       else ASSERT(!uses >= !calls, "unknown sanity");
179       if !uses < 0 then bug "decrementing too much" (* F.VAR lv) *)       if !uses < 0 then bug "decrementing too much" (* F.VAR lv) *)
180       else !uses = 0)       else !uses = 0)
181    
182  fun usenb ({uses=ref uses,...}:info) = uses  fun usenb (Info{uses=ref uses,...}) = uses
183  fun used ({uses,...}:info) = !uses > 0  fun used (Info{uses,...}) = !uses > 0
184  fun escaping ({uses,calls,...}:info) = !uses > !calls  fun dead (Info{uses,...}) = !uses = 0
185  fun called ({calls,...}:info) = !calls > 0  fun escaping (Info{uses,calls,...}) = !uses > !calls
186    fun called (Info{calls,...}) = !calls > 0
187    fun iusenb (Info{int=ref(u,_),...}) = u
188    fun icallnb (Info{int=ref(_,c),...}) = c
189    fun ireset (Info{int,...}) = int := (0,0)
190    
191  (* 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
192   * conservative when keeping the counts uptodate *)   * conservative when keeping the counts uptodate *)
# Line 221  Line 236 
236      (* the actual function:      (* the actual function:
237       * `uvs' is an optional list of booleans representing which of       * `uvs' is an optional list of booleans representing which of
238       * the return values are actually used *)       * the return values are actually used *)
239      fun cexp uvs lexp =      fun cexp lexp =
240          (case lexp          (case lexp
241           of F.RET vs => app use vs           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) *)  
242    
243            | F.LET (lvs,le1,le2) =>            | F.LET (lvs,le1,le2) =>
244              let val lvsi = map newv lvs              let val lvsi = map newv lvs
245              in cexp uvs le2; cexp (usage(map used lvsi)) le1              in cexp le2; cexp le1
246              end              end
247    
248            | F.FIX (fs,le) =>            | F.FIX (fs,le) =>
249              let val fs = map (fn (_,f,args,body) =>              let val fs = map (fn (_,f,args,body) =>
250                                (newf (SOME(map #1 args)) f,args,body))                                (newf (SOME(map #1 args)) f,args,body))
251                               fs                               fs
252                  fun cfun (_,args,body) = (* census of a fundec *)                  fun cfun (Info{uses,calls, int, ...}, args,body) =
253                      (app (fn (v,t) => ignore(newv v)) args; cexp All body)                      (* census of a fundec.  We get the internal counts
254                         * by examining the count difference between before
255                         * and after census of the body. *)
256                        let val (euses,ecalls) = (!uses,!calls)
257                        in
258                            app (fn (v,t) => ignore(newv v)) args;
259                            cexp body;
260                            int := (!uses - euses, !calls - ecalls)
261                        end
262                  fun cfix fs =   (* census of a list of fundecs *)                  fun cfix fs =   (* census of a list of fundecs *)
263                      let val (ufs,nfs) = List.partition (used o #1) fs                      let val (ufs,nfs) = List.partition (used o #1) fs
264                      in if List.null ufs then ()                      in if List.null ufs then ()
265                         else (app cfun ufs; cfix nfs)                         else (app cfun ufs; cfix nfs)
266                      end                      end
267              in cexp uvs le; cfix fs              in cexp le; cfix fs
268              end              end
269    
270            | F.APP (F.VAR f,vs) =>            | F.APP (F.VAR f,vs) =>
# Line 253  Line 272 
272    
273            | F.TFN ((tf,args,body),le) =>            | F.TFN ((tf,args,body),le) =>
274              let val tfi = newf NONE tf              let val tfi = newf NONE tf
275              in cexp uvs le;              in cexp le; if used tfi then cexp body else ()
                 if used tfi then cexp All body else ()  
276              end              end
277    
278            | F.TAPP (F.VAR tf,tycs) => call NONE tf            | F.TAPP (F.VAR tf,tycs) => call NONE tf
279    
280            | F.SWITCH (v,cs,arms,def) =>            | F.SWITCH (v,cs,arms,def) =>
281              (use v; Option.map (cexp uvs) def;              (use v; Option.map cexp def;
282               app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp uvs le)               app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp le)
283                     | (_,le) => cexp uvs le)                     | (_,le) => cexp le)
284                   arms)                   arms)
285    
286            | F.CON (dc,_,v,lv,le) =>            | F.CON (dc,_,v,lv,le) =>
287              let val lvi = newv lv              let val lvi = newv lv
288              in cdcon dc; cexp uvs le; if used lvi then use v else ()              in cdcon dc; cexp le; if used lvi then use v else ()
289              end              end
290    
291            | F.RECORD (_,vs,lv,le) =>            | F.RECORD (_,vs,lv,le) =>
292              let val lvi = newv lv              let val lvi = newv lv
293              in cexp uvs le; if used lvi then app use vs else ()              in cexp le; if used lvi then app use vs else ()
294              end              end
295    
296            | F.SELECT (v,_,lv,le) =>            | F.SELECT (v,_,lv,le) =>
297              let val lvi = newv lv              let val lvi = newv lv
298              in cexp uvs le; if used lvi then use v else ()              in cexp le; if used lvi then use v else ()
299              end              end
300    
301            | F.RAISE (v,_) => use v            | F.RAISE (v,_) => use v
302            | F.HANDLE (le,v) => (use v; cexp uvs le)            | F.HANDLE (le,v) => (use v; cexp le)
303    
304            | F.BRANCH (po,vs,le1,le2) =>            | F.BRANCH (po,vs,le1,le2) =>
305              (app use vs; cpo po; cexp uvs le1; cexp uvs le2)              (app use vs; cpo po; cexp le1; cexp le2)
306    
307            | F.PRIMOP (po,vs,lv,le) =>            | F.PRIMOP (po,vs,lv,le) =>
308              let val lvi = newv lv              let val lvi = newv lv
309              in cexp uvs le;              in cexp le;
310                  if impurePO po orelse used lvi then (cpo po; app use vs) else ()                  if impurePO po orelse used lvi then (cpo po; app use vs) else ()
311              end              end
312    
# Line 395  Line 413 
413      cexp      cexp
414  end  end
415    
416  val uselexp = census All  val uselexp = census
417  fun copylexp alpha le =  fun copylexp alpha le =
418      let val nle = FU.copy alpha le      let val nle = FU.copy alpha le
419      in uselexp nle; nle      in uselexp nle; nle

Legend:
Removed from v.188  
changed lines
  Added in v.189

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