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

sml/branches/SMLNJ/src/compiler/FLINT/flint/flintutil.sml revision 93, Tue May 12 21:56:22 1998 UTC sml/trunk/src/compiler/FLINT/flint/flintutil.sml revision 489, Tue Nov 23 12:55:00 1999 UTC
# Line 18  Line 18 
18    val getWrapTyc   : FLINT.primop -> FLINT.tyc    val getWrapTyc   : FLINT.primop -> FLINT.tyc
19    val getUnWrapTyc : FLINT.primop -> FLINT.tyc    val getUnWrapTyc : FLINT.primop -> FLINT.tyc
20    
21    val copy : (unit -> FLINT.lvar) -> FLINT.prog -> FLINT.prog    (* copy a lexp with alpha renaming.
22       * free variables remain unchanged except for the renaming specified
23       * in the first (types) and second (values) argument *)
24      val copy : (FLINT.tvar * FLINT.tyc) list ->
25                 FLINT.lvar IntBinaryMap.map ->
26                 FLINT.lexp -> FLINT.lexp
27      val copyfdec : FLINT.fundec -> FLINT.fundec
28    
29      val freevars : FLINT.lexp -> IntBinarySet.set
30    
31      val dcon_eq : FLINT.dcon * FLINT.dcon -> bool
32    
33  end (* signature FLINTUTIL *)  end (* signature FLINTUTIL *)
34    
35    
# Line 29  Line 40 
40        structure LT = LtyExtern        structure LT = LtyExtern
41        structure PO = PrimOp        structure PO = PrimOp
42        structure DA = Access        structure DA = Access
43          structure M  = IntBinaryMap
44          structure A  = Access
45          structure O  = Option
46          structure S  = IntBinarySet
47          structure F  = FLINT
48        open FLINT        open FLINT
49  in  in
50    
# Line 73  Line 89 
89  fun getUnWrapTyc (_, _, lt, []) = LT.ltd_tyc(#2(LT.ltd_parrow lt))  fun getUnWrapTyc (_, _, lt, []) = LT.ltd_tyc(#2(LT.ltd_parrow lt))
90    | getUnWrapTyc _ = bug "unexpected case in getUnWrapTyc"    | getUnWrapTyc _ = bug "unexpected case in getUnWrapTyc"
91    
92    fun dcon_eq ((s1,c1,t1),(s2,c2,t2)) =
93        (s1 = s2) andalso (c1 = c2) andalso LtyBasic.lt_eqv(t1, t2)
94    
95    val cplv = LambdaVar.dupLvar
96  (*  (*
97   * general alpha-conversion on lexp free variables remain unchanged   * general alpha-conversion on lexp free variables remain unchanged
98   *   val copy: (unit -> lvar) -> fundec -> fundec   * except for the renaming specified in the first argument.
99     *   val copy: lvar M.intmap -> fundec -> fundec
100   *)   *)
101  fun copy mkLvar = let  fun copy ta alpha le = let
   
     fun look m v = (IntmapF.lookup m v) handle IntmapF.IntmapF => v  
     fun rename (lv, m) =  
       let val lv' = mkLvar ()  
           val m' = IntmapF.add (m, lv, lv')  
        in (lv', m')  
       end  
   
     fun renamevs (vs, m) =  
       let fun h([], nvs, nm) = (rev nvs, nm)  
             | h(a::r, nvs, nm) =  
                  let val (a', nm') = rename(a, nm)  
                   in h(r, a'::nvs, nm')  
                  end  
        in h(vs, [], m)  
       end  
   
     fun renamevps (vps, m) =  
       let fun h([], nvs, nm) = (rev nvs, nm)  
             | h((a,t)::r, nvs, nm) =  
                  let val (a', nm') = rename(a, nm)  
                   in h(r, (a',t)::nvs, nm')  
                  end  
        in h(vps, [], m)  
       end  
   
     (* access *)  
     fun ca (DA.LVAR v, m) = DA.LVAR (look m v)  
       | ca (DA.PATH (a, i), m) = DA.PATH (ca (a, m), i)  
       | ca (a, _) = a  
   
     (* conrep *)  
     fun ccr (DA.EXN a, m) = DA.EXN (ca (a, m))  
       | ccr (cr, _) = cr  
102    
103      (* dataconstr *)      val tc_subst = LT.tc_nvar_subst_gen()
104      fun cdc ((s, cr, t), m) = (s, ccr (cr, m), t)      val lt_subst = LT.lt_nvar_subst_gen()
105    
106      (* con *)      val tmap_sort = ListMergeSort.sort (fn ((v1,_),(v2,_)) => v1 > v2)
     fun ccon (DATAcon (dc, ts, v), m) =  
           let val (nv, m') = rename(v, m)  
            in (DATAcon (cdc(dc, m), ts, nv), m')  
           end  
       | ccon x = x  
   
     (* dict *)  
     fun dict ({default=v, table=tbls}, m) =  
       let val nv = look m v  
           val ntbls = map (fn (x, v) => (x, look m v)) tbls  
        in {default=nv, table=ntbls}  
       end  
107    
108      (* primop *)      fun substvar alpha lv = case M.find(alpha,lv) of SOME(lv) => lv | NOE => lv
109      fun cprim (p as (NONE, _, _, _), m) = p      fun substval alpha (VAR lv) = VAR(substvar alpha lv)
110        | cprim ((SOME d, p, lt, ts), m) = (SOME (dict(d, m)), p, lt, ts)        | substval alpha v = v
111        fun newv (lv,alpha) =
112      (* value *)          let val nlv = cplv lv in (nlv, M.insert(alpha,lv,nlv)) end
113      fun sv (VAR lv, m) = VAR (look m lv)      fun newvs (lvs,alpha) =
114        | sv (x as INT _, _) = x          foldr (fn (lv,(lvs,alpha)) =>
115        | sv (x as INT32 _, _) = x                 let val (nlv,nalpha) = newv(lv,alpha) in (nlv::lvs,nalpha) end)
116        | sv (x as WORD _, _) = x                ([],alpha) lvs
117        | sv (x as WORD32 _, _) = x      fun cdcon ta alpha (s,ac,lty) =
118        | sv (x as REAL _, _) = x          (s,
119        | sv (x as STRING _, _) = x           case ac
120              of A.EXN(A.LVAR lv) => A.EXN(A.LVAR(substvar alpha lv))
121      (* value list *)             | _ => ac,
122      fun svs (vs, m) =           lt_subst ta lty)
123        let fun h([], res, m) = rev res      fun cpo ta alpha (dict,po,lty,tycs) =
124              | h(v::r, res, m) = h(r, (sv(v, m))::res, m)          (O.map (fn {default,table} =>
125         in h(vs, [], m)                  {default=substvar alpha default,
126        end                   table=map (fn (tycs,lv) =>
127                                (map (tc_subst ta) tycs, substvar alpha lv))
128      (* lexp *)                             table}) dict,
129      fun c (RET vs, m) = RET (svs (vs, m))           po, lt_subst ta lty, map (tc_subst ta) tycs)
130        | c (APP (v, vs), m) = APP (sv (v, m), svs (vs, m))      fun cfk ta {isrec=SOME(ltys,lk),known,inline,cconv} =
131        | c (TAPP (v, ts), m) = TAPP (sv (v, m), ts)          {isrec=SOME(map (lt_subst ta) ltys,lk),
132        | c (FIX (fdecs, le), m) =           known=known, inline=inline, cconv=cconv}
133             let val (fdecs', nm) = cf(fdecs, m)        | cfk _ fk = fk
134              in FIX(fdecs', c(le, nm))  
135             end      fun crk ta (RK_VECTOR tyc) = RK_VECTOR(tc_subst ta tyc)
136        | c (LET (vs, le1, le2), m) =        | crk _ rk = rk
137             let val le1' = c(le1, m)  
138                 val (nvs, m') = renamevs(vs, m)      fun copy' ta alpha le = let
139              in LET(nvs, le1', c(le2, m'))          val cpo = cpo ta alpha
140             end          val cdcon = cdcon ta alpha
141        | c (TFN (tfdec, le), m) =          val substvar = substvar alpha
142             let val (tfdec', nm) = ctf(tfdec, m)          val substval = substval alpha
143              in TFN(tfdec', c(le, nm))          val copy = copy' ta
144             end      in case le
145        of RET vs => RET(map substval vs)
146        | c (SWITCH (v, crl, cel, eo), m) =       | LET (lvs,le,body) =>
147             let fun cc (con, x) =         let val nle = copy alpha le
148                   let val (ncon, m') = ccon (con, m)             val (nlvs,nalpha) = newvs(lvs,alpha)
149                    in (ncon, c (x, m'))         in LET(nlvs, nle, copy nalpha body)
150                   end         end
151                 fun co NONE = NONE       | FIX (fdecs,le) =>
152                   | co (SOME x) = SOME (c (x, m))         let fun cfun alpha ((fk,f,args,body):fundec,nf) =
153              in SWITCH (sv (v, m), crl, map cc cel, co eo)                 let val (nargs,nalpha) = newvs(map #1 args, alpha)
154             end                 in (cfk ta fk, nf,
155        | c (CON (dc, ts, u, v, le), m) =                     ListPair.zip(nargs, (map (lt_subst ta o #2) args)),
156             let val (nv, nm) = rename(v, m)                     copy nalpha body)
             in CON (cdc (dc, m), ts, sv (u, m), nv, c(le, nm))  
            end  
       | c (RECORD (rk, vs, v, le), m) =  
            let val (nv, nm) = rename(v, m)  
             in RECORD (rk, svs (vs, m), nv, c(le, nm))  
            end  
       | c (SELECT (u, i, v, le), m) =  
            let val (nv, nm) = rename(v, m)  
             in SELECT (sv (u,m), i, nv, c(le, nm))  
            end  
       | c (RAISE (v, ts), m) = RAISE (sv (v, m), ts)  
       | c (HANDLE (e, v), m) = HANDLE (c (e, m), sv (v, m))  
       | c (BRANCH (p, vs, e1, e2), m) =  
            BRANCH (cprim(p, m), svs(vs, m), c(e1, m), c(e2, m))  
       | c (PRIMOP (p, vs, v, le), m) =  
            let val (nv, nm) = rename(v, m)  
             in PRIMOP(cprim(p,m), svs(vs, m), nv, c(le, nm))  
            end  
   
     and ctf ((v,args,le), m) =  
       let val (nv, nm) = rename(v, m)  
           (*** ZSH-WARNING: I didn't bother to rename tvars in args ***)  
        in ((nv, args, c(le, m)), nm)  
       end  
   
     and cf (fdecs, m) =  
       let fun pass1([], res, m) = (rev res, m)  
             | pass1((_, v, _, _)::r, res, m) =  
                 let val (nv, nm) = rename(v, m)  
                  in pass1(r, nv::res, nm)  
                 end  
   
           val (nvs, nm) = pass1(fdecs, [], m)  
   
           fun pass2([], [], res) = (rev res, nm)  
             | pass2((fk, _, args, le)::r, nv::nvs, res) =  
                 let val (args', nm') = renamevps(args, nm)  
                  in pass2(r, nvs, (fk, nv, args', c(le, nm'))::res)  
                 end  
             | pass2 _ = bug "unexpected cases in cf - pass2"  
        in pass2(fdecs, nvs, [])  
157        end        end
158               val (nfs, nalpha) = newvs(map #2 fdecs, alpha)
159               val nfdecs = ListPair.map (cfun nalpha) (fdecs, nfs)
160  in  in
161      fn fdec =>             FIX(nfdecs, copy nalpha le)
162        let val init = IntmapF.empty         end
163            val (fdecs', _) = cf([fdec], init)       | APP (f,args) => APP(substval f, map substval args)
164         in (case fdecs'       | TFN ((tfk,lv,args,body),le) =>
165              of [x] => x         (* don't forget to rename the tvar also *)
166               | _ => bug "unexpected cases in copy - top")         let val (nlv,nalpha) = newv(lv,alpha)
167               val (nargs,ialpha) = newvs(map #1 args, nalpha)
168               val ita = tmap_sort ((ListPair.map
169                                         (fn ((t,k),nt) => (t, LT.tcc_nvar nt))
170                                         (args, nargs)) @ ta)
171           in TFN((tfk,nlv,
172                   ListPair.zip(nargs, map #2 args),
173                   copy' ita ialpha body),
174                  copy nalpha le)
175           end
176         | TAPP (f,tycs) => TAPP(substval f, map (tc_subst ta) tycs)
177         | SWITCH (v,ac,arms,def) =>
178           let fun carm (DATAcon(dc,tycs,lv),le) =
179                   let val (nlv,nalpha) = newv(lv, alpha)
180                   in (DATAcon(cdcon dc, map (tc_subst ta) tycs, nlv),
181                       copy nalpha le)
182                   end
183                 | carm (con,le) = (con, copy alpha le)
184           in SWITCH(substval v, ac, map carm arms, Option.map (copy alpha) def)
185           end
186         | CON (dc,tycs,v,lv,le) =>
187           let val (nlv,nalpha) = newv(lv, alpha)
188           in CON(cdcon dc, map (tc_subst ta) tycs, substval v, nlv, copy nalpha le)
189           end
190         | RECORD (rk,vs,lv,le) =>
191           let val (nlv,nalpha) = newv(lv, alpha)
192           in RECORD(crk ta rk, map substval vs, nlv, copy nalpha le)
193           end
194         | SELECT (v,i,lv,le) =>
195           let val (nlv,nalpha) = newv(lv, alpha)
196           in SELECT(substval v, i, nlv, copy nalpha le)
197           end
198         | RAISE (v,ltys) => RAISE(substval v, map (lt_subst ta) ltys)
199         | HANDLE (le,v) => HANDLE(copy alpha le, substval v)
200         | BRANCH (po,vs,le1,le2) =>
201           BRANCH(cpo po, map substval vs, copy alpha le1, copy alpha le2)
202         | PRIMOP (po,vs,lv,le) =>
203           let val (nlv,nalpha) = newv(lv, alpha)
204           in PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)
205           end
206        end
207    in copy' (tmap_sort ta) alpha le
208    end
209    fun copyfdec fdec =
210        case copy [] M.empty (F.FIX([fdec], F.RET[]))
211         of F.FIX([nfdec], F.RET[]) => nfdec
212          | _ => bug "copyfdec"
213    
214    fun freevars lexp = let
215        val loop = freevars
216    
217        fun S_rmv(x, s) = S.delete(s, x) handle NotFound => s
218    
219        fun addv (s,F.VAR lv) = S.add(s, lv)
220          | addv (s,_) = s
221        fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
222        fun rmvs (s,lvs) = foldl (fn (l,s) => S_rmv (l, s)) s lvs
223        fun singleton (F.VAR v) = S.singleton v
224          | singleton _ = S.empty
225    
226        fun fpo (fv,(NONE:F.dict option,po,lty,tycs)) = fv
227          | fpo (fv,(SOME{default,table},po,lty,tycs)) =
228            addvs(addv(fv, F.VAR default), map (F.VAR o #2) table)
229    
230        fun fdcon (fv,(s,Access.EXN(Access.LVAR lv),lty)) = addv(fv, F.VAR lv)
231          | fdcon (fv,_) = fv
232    
233    in case lexp
234        of F.RET vs => addvs(S.empty, vs)
235         | F.LET (lvs,body,le) => S.union(rmvs(loop le, lvs), loop body)
236         | F.FIX (fdecs,le) =>
237           rmvs((foldl (fn ((_,_,args,body),fv) =>
238                        S.union(rmvs(loop body, map #1 args), fv))
239                       (loop le) fdecs),
240                map #2 fdecs)
241         | F.APP (f,args) => addvs(S.empty, f::args)
242         | F.TFN ((tfk,f,args,body),le) => S.union(S_rmv(f, loop le), loop body)
243         | F.TAPP (f,args) => singleton f
244         | F.SWITCH (v,ac,arms,def) =>
245           let fun farm ((dc,le),fv) =
246                   let val fvle = loop le
247                   in S.union(fv,
248                              case dc
249                               of F.DATAcon(dc,_,lv) => fdcon(S_rmv(lv, fvle),dc)
250                                | _ => fvle)
251                   end
252               val fvs = case def of NONE => singleton v
253                                   | SOME le => addv(loop le, v)
254           in foldl farm fvs arms
255           end
256         | F.CON (dc,tycs,v,lv,le) => fdcon(addv(S_rmv(lv, loop le), v),dc)
257         | F.RECORD (rk,vs,lv,le) => addvs(S_rmv(lv, loop le), vs)
258         | F.SELECT (v,i,lv,le) => addv(S_rmv(lv, loop le), v)
259         | F.RAISE (v,ltys) => singleton v
260         | F.HANDLE (le,v) => addv(loop le, v)
261         | F.BRANCH (po,vs,le1,le2) => fpo(addvs(S.union(loop le1, loop le2), vs), po)
262         | F.PRIMOP (po,vs,lv,le) => fpo(addvs(S_rmv(lv, loop le), vs),po)
263        end        end
 end (* function copy *)  
264    
265  end (* top-level local *)  end (* top-level local *)
266  end (* structure FlintUtil *)  end (* structure FlintUtil *)
   
 (*  
  * $Log: flintutil.sml,v $  
  * Revision 1.1.1.1  1998/04/08 18:39:38  george  
  * Version 110.5  
  *  
  *)  

Legend:
Removed from v.93  
changed lines
  Added in v.489

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