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

Diff of /sml/trunk/src/compiler/FLINT/clos/freeclose.sml

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

revision 732, Mon Nov 13 21:59:12 2000 UTC revision 733, Fri Nov 17 05:13:45 2000 UTC
# Line 34  Line 34 
34    end    end
35  in  in
36    
37        structure IS = IntRedBlackSet
38        structure IM = IntRedBlackMap
39        structure Nd = struct
40            type ord_key = int
41            val compare = Int.compare
42        end
43    
44        structure SCC = GraphSCCFn (Nd)
45    
46  (***************************************************************************  (***************************************************************************
47   *  Misc and utility functions                                             *   *  Misc and utility functions                                             *
48   ***************************************************************************)   ***************************************************************************)
# Line 192  Line 201 
201  (***************************************************************************  (***************************************************************************
202   * Build the call graph and compute the scc number                         *   * Build the call graph and compute the scc number                         *
203   ***************************************************************************)   ***************************************************************************)
204    
205    fun KUC x = (contP x) orelse (knownP x) orelse (usersP x)
206    
207    fun mkgraph f = let
208        fun comb ((xe, xf), (ye, yf)) = (IS.union (xe, ye), xf @ yf)
209        fun combe ((xe, xf), e) = (IS.union (xe, e), xf)
210        fun combf ((xe, xf), f) = (xe, xf @ f)
211        fun addKUC (s, v) = if KUC v then IS.add (s, v) else s
212        fun vl2sKUC l = let
213            fun loop ([], s) = s
214              | loop (VAR v :: r, s) = loop (r, addKUC (s, v))
215              | loop (_ :: r, s) = loop (r, s)
216        in
217            loop (l, IS.empty)
218        end
219        fun collect (SWITCH (_, _, el)) =
220            foldl (fn (x, a) => comb (collect x, a)) (IS.empty, []) el
221          | collect (SETTER (P.sethdlr, vl, e)) = combe (collect e, vl2sKUC vl)
222          | collect (RECORD (_, _, _, e) |
223                     SELECT (_, _, _, _, e) |
224                     OFFSET (_, _, _, e) |
225                     SETTER (_, _, e) |
226                     LOOKER (_, _, _, _, e) |
227                     ARITH (_, _, _, _, e) |
228                     PURE (_, _, _, _, e)) = collect e
229          | collect (BRANCH (_, _, _, x, y)) = comb (collect x, collect y)
230          | collect (APP (u, ul)) = (vl2sKUC (u :: ul), [])
231          | collect (FIX (fl, b)) = combf (collect b, fl)
232        fun dofun ((_, f, _, _, body), (m, all)) = let
233            val (es, fl) = collect body
234            val m' = IM.insert (m, f, IS.listItems es)
235            val all' = IS.add (all, f)
236        in
237            foldl dofun (m', all') fl
238        end
239        val (follow_map, allset) = dofun (f, (IM.empty, IS.empty))
240        val rootedges = IS.listItems allset
241        val root = (foldl Int.max 0 rootedges) + 1
242        val follow_map = IM.insert (follow_map, root, rootedges)
243        fun follow v = valOf (IM.find (follow_map, v))
244    in
245        { root = root, follow = follow }
246    end
247    
248    fun assNum (SCC.SIMPLE v, (i, nm)) =
249        (i + 1, IM.insert (nm, v, i))
250      | assNum (SCC.RECURSIVE vl, (i, nm)) =
251        (i + 1, foldl (fn (v, nm) => IM.insert (nm, v, i)) nm vl)
252    
253    (* first component is fake root node, it receives number ~1 *)
254    val number_map = #2 (foldl assNum (~1, IM.empty) (SCC.topOrder (mkgraph fe')))
255    
256    fun sccnum x = valOf (IM.find (number_map, x))
257    
258    (*
259  exception Unseen  exception Unseen
260  type info = {dfsnum : int ref, sccnum : int ref, edges : lvar list}  type info = {dfsnum : int ref, sccnum : int ref, edges : lvar list}
261  val m : info Intmap.intmap = Intmap.new(32,Unseen)  val m : info IntHashTable.hash_table = IntHashTable.mkTable(32,Unseen)
262  val lookup = Intmap.map m  val lookup = IntHashTable.lookup m
263  val total : lvar list ref = ref nil  val total : lvar list ref = ref nil
264    
265  fun addinfo(f,vl) = (total := (f :: (!total));  fun addinfo(f,vl) =
266                       Intmap.add m (f,{dfsnum=ref ~1,sccnum=ref ~1,edges=vl}))      (total := (f :: (!total));
267         IntHashTable.insert m (f,{dfsnum=ref ~1,sccnum=ref ~1,edges=vl}))
268  fun KUC x = (contP x) orelse (knownP x) orelse (usersP x)  fun KUC x = (contP x) orelse (knownP x) orelse (usersP x)
269  fun EC x = (contP x) orelse (escapesP x)  fun EC x = (contP x) orelse (escapesP x)
270    
# Line 247  Line 312 
312  val _ = makenode(fe')               (* Build the call graph *)  val _ = makenode(fe')               (* Build the call graph *)
313  val _ = app (fn x => (scc x; ())) (!total)   (* Compute the scc number *)  val _ = app (fn x => (scc x; ())) (!total)   (* Compute the scc number *)
314  val sccnum = ! o #sccnum o lookup  val sccnum = ! o #sccnum o lookup
315    *)
316  fun samescc(x,n) = if n < 0 then false else ((sccnum x) = n)  fun samescc(x,n) = if n < 0 then false else ((sccnum x) = n)
317    
318  (***>>  (***>>
# Line 354  Line 420 
420   *                 (2) lvar to freevar information                         *   *                 (2) lvar to freevar information                         *
421   ***************************************************************************)   ***************************************************************************)
422  exception STAGENUM  exception STAGENUM
423  val snum : snum Intmap.intmap = Intmap.new(32,STAGENUM)  val snum : snum IntHashTable.hash_table = IntHashTable.mkTable(32,STAGENUM)
424  val addsn = Intmap.add snum   (* add the stage number for a fundef *)  val addsn = IntHashTable.insert snum    (* add the stage number for a fundef *)
425  val getsn = Intmap.map snum   (* get the stage number of a fundef *)  val getsn = IntHashTable.lookup snum    (* get the stage number of a fundef *)
426    
427  fun findsn(v,d,[]) = (warn ("Fundef " ^ (LV.lvarName v)  fun findsn(v,d,[]) = (warn ("Fundef " ^ (LV.lvarName v)
428                              ^ " unused in freeClose"); d)                              ^ " unused in freeClose"); d)
# Line 373  Line 439 
439    
440    
441  exception FREEVMAP  exception FREEVMAP
442  val vars : fvinfo Intmap.intmap = Intmap.new(32,FREEVMAP)  val vars : fvinfo IntHashTable.hash_table = IntHashTable.mkTable(32,FREEVMAP)
443    
444  fun addEntry(v,l,x,s) = Intmap.add vars (v,{fv=l,lv=x,sz=s})  fun addEntry(v,l,x,s) = IntHashTable.insert vars (v,{fv=l,lv=x,sz=s})
445  val freeV = Intmap.map vars    (* get the freevar info *)  val freeV = IntHashTable.lookup vars    (* get the freevar info *)
446  val loopV = #lv o freeV        (* the free variables on the loop path *)  val loopV = #lv o freeV        (* the free variables on the loop path *)
447    
448  (***>>  (***>>
449    val vars : (lvar list * (lvar list option)) Intmap.intmap    val vars : (lvar list * (lvar list option)) IntHashTable.hash_table
450                                                 = Intmap.new(32, FREEVMAP)                                             = IntHashTable.mkTable(32, FREEVMAP)
451    val freeV = Intmap.map vars    val freeV = IntHashTable.lookup vars
452    fun loopV v = (#2 (freeV v)) handle FREEVMAP => error "loopV in closure"    fun loopV v = (#2 (freeV v)) handle FREEVMAP => error "loopV in closure"
453  <<***)  <<***)
454    
# Line 632  Line 698 
698    
699  end  end
700  end (* structure FreeClose *)  end (* structure FreeClose *)
   
   

Legend:
Removed from v.732  
changed lines
  Added in v.733

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