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

Diff of /sml/trunk/src/compiler/FLINT/flint/flintutil.sml

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

revision 197, Sun Nov 22 01:25:23 1998 UTC revision 216, Fri Feb 26 12:55:26 1999 UTC
# Line 24  Line 24 
24    val copy : (FLINT.tvar * FLINT.tyc) list ->    val copy : (FLINT.tvar * FLINT.tyc) list ->
25               FLINT.lvar IntmapF.intmap ->               FLINT.lvar IntmapF.intmap ->
26               FLINT.lexp -> FLINT.lexp               FLINT.lexp -> FLINT.lexp
27      val copyfdec : FLINT.fundec -> FLINT.fundec
28    
29      val freevars : FLINT.lexp -> IntSetF.intset
30    
31    val dcon_eq : FLINT.dcon * FLINT.dcon -> bool    val dcon_eq : FLINT.dcon * FLINT.dcon -> bool
32    
# Line 40  Line 43 
43        structure M  = IntmapF        structure M  = IntmapF
44        structure A  = Access        structure A  = Access
45        structure O  = Option        structure O  = Option
46          structure S  = IntSetF
47          structure F  = FLINT
48        open FLINT        open FLINT
49  in  in
50    
# Line 98  Line 103 
103      val tc_subst = LT.tc_nvar_subst_gen()      val tc_subst = LT.tc_nvar_subst_gen()
104      val lt_subst = LT.lt_nvar_subst_gen()      val lt_subst = LT.lt_nvar_subst_gen()
105    
106        val tmap_sort = Sort.sort (fn ((v1,_),(v2,_)) => v1 > v2)
107    
108      fun substvar alpha lv = ((M.lookup alpha lv) handle M.IntmapF => lv)      fun substvar alpha lv = ((M.lookup alpha lv) handle M.IntmapF => lv)
109      fun substval alpha (VAR lv) = VAR(substvar alpha lv)      fun substval alpha (VAR lv) = VAR(substvar alpha lv)
110        | substval alpha v = v        | substval alpha v = v
# Line 158  Line 165 
165         (* don't forget to rename the tvar also *)         (* don't forget to rename the tvar also *)
166         let val (nlv,nalpha) = newv(lv,alpha)         let val (nlv,nalpha) = newv(lv,alpha)
167             val (nargs,ialpha) = newvs(map #1 args, nalpha)             val (nargs,ialpha) = newvs(map #1 args, nalpha)
168             val ita = (ListPair.map (fn (t,nt) => (t, LT.tcc_nvar nt))             val ita = tmap_sort ((ListPair.map
169                                     (map #1 args, nargs)) @ ta                                       (fn ((t,k),nt) => (t, LT.tcc_nvar nt))
170                                         (args, nargs)) @ ta)
171         in TFN((nlv, ListPair.zip(nargs, map #2 args), copy' ita ialpha body),         in TFN((nlv, ListPair.zip(nargs, map #2 args), copy' ita ialpha body),
172                  copy nalpha le)                  copy nalpha le)
173         end         end
# Line 194  Line 202 
202         in PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)         in PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)
203         end         end
204      end      end
205  in copy' ta alpha le  in copy' (tmap_sort ta) alpha le
206    end
207    fun copyfdec fdec =
208        case copy [] M.empty (F.FIX([fdec], F.RET[]))
209         of F.FIX([nfdec], F.RET[]) => nfdec
210          | _ => bug "copyfdec"
211    
212    fun freevars lexp = let
213        val loop = freevars
214    
215        fun addv (s,F.VAR lv) = S.add(lv, s)
216          | addv (s,_) = s
217        fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
218        fun rmvs (s,lvs) = foldl S.rmv s lvs
219        fun singleton (F.VAR v) = S.singleton v
220          | singleton _ = S.empty
221    
222        fun fpo (fv,(NONE:F.dict option,po,lty,tycs)) = fv
223          | fpo (fv,(SOME{default,table},po,lty,tycs)) =
224            addvs(addv(fv, F.VAR default), map (F.VAR o #2) table)
225    
226        fun fdcon (fv,(s,Access.EXN(Access.LVAR lv),lty)) = addv(fv, F.VAR lv)
227          | fdcon (fv,_) = fv
228    
229    in case lexp
230        of F.RET vs => addvs(S.empty, vs)
231         | F.LET (lvs,body,le) => S.union(rmvs(loop le, lvs), loop body)
232         | F.FIX (fdecs,le) =>
233           rmvs((foldl (fn ((_,_,args,body),fv) =>
234                        S.union(rmvs(loop body, map #1 args), fv))
235                       (loop le) fdecs),
236                map #2 fdecs)
237         | F.APP (f,args) => addvs(S.empty, f::args)
238         | F.TFN ((f,args,body),le) => S.union(S.rmv(f, loop le), loop body)
239         | F.TAPP (f,args) => singleton f
240         | F.SWITCH (v,ac,arms,def) =>
241           let fun farm ((dc,le),fv) =
242                   let val fvle = loop le
243                   in S.union(fv,
244                              case dc
245                               of F.DATAcon(dc,_,lv) => fdcon(S.rmv(lv, fvle),dc)
246                                | _ => fvle)
247                   end
248           in foldl farm (case def of NONE => S.empty | SOME le => loop le) arms
249           end
250         | F.CON (dc,tycs,v,lv,le) => fdcon(addv(S.rmv(lv, loop le), v),dc)
251         | F.RECORD (rk,vs,lv,le) => addvs(S.rmv(lv, loop le), vs)
252         | F.SELECT (v,i,lv,le) => addv(S.rmv(lv, loop le), v)
253         | F.RAISE (v,ltys) => singleton v
254         | F.HANDLE (le,v) => addv(loop le, v)
255         | F.BRANCH (po,vs,le1,le2) => fpo(addvs(S.union(loop le1, loop le2), vs), po)
256         | F.PRIMOP (po,vs,lv,le) => fpo(addvs(S.rmv(lv, loop le), vs),po)
257  end  end
   
258    
259  end (* top-level local *)  end (* top-level local *)
260  end (* structure FlintUtil *)  end (* structure FlintUtil *)

Legend:
Removed from v.197  
changed lines
  Added in v.216

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