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 153, Sun Oct 11 17:49:09 1998 UTC revision 154, Sun Oct 11 22:22:47 1998 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 argument *)
24      val copy : FLINT.lvar IntmapF.intmap -> FLINT.lexp -> FLINT.lexp
25    
26      val dcon_eq : FLINT.dcon * FLINT.dcon -> bool
27    
28  end (* signature FLINTUTIL *)  end (* signature FLINTUTIL *)
29    
30    
# Line 29  Line 35 
35        structure LT = LtyExtern        structure LT = LtyExtern
36        structure PO = PrimOp        structure PO = PrimOp
37        structure DA = Access        structure DA = Access
38          structure M  = IntmapF
39        open FLINT        open FLINT
40  in  in
41    
# Line 73  Line 80 
80  fun getUnWrapTyc (_, _, lt, []) = LT.ltd_tyc(#2(LT.ltd_parrow lt))  fun getUnWrapTyc (_, _, lt, []) = LT.ltd_tyc(#2(LT.ltd_parrow lt))
81    | getUnWrapTyc _ = bug "unexpected case in getUnWrapTyc"    | getUnWrapTyc _ = bug "unexpected case in getUnWrapTyc"
82    
83    fun dcon_eq ((s1,c1,t1),(s2,c2,t2)) =
84        (s1 = s2) andalso (c1 = c2) andalso LtyBasic.lt_eqv(t1, t2)
85    
86    val cplv = LambdaVar.dupLvar
87  (*  (*
88   * general alpha-conversion on lexp free variables remain unchanged   * general alpha-conversion on lexp free variables remain unchanged
89   *   val copy: (unit -> lvar) -> fundec -> fundec   * except for the renaming specified in the first argument.
90     *   val copy: lvar M.intmap -> fundec -> fundec
91   *)   *)
92  fun copy mkLvar = let  fun copy alpha le = let
93        fun substvar lv = ((M.lookup alpha lv) handle M.IntmapF => lv)
94      fun look m v = (IntmapF.lookup m v) handle IntmapF.IntmapF => v      fun substval (VAR lv) = VAR(substvar lv)
95      fun rename (lv, m) =        | substval v = v
96        let val lv' = mkLvar ()      fun newv (lv,alpha) =
97            val m' = IntmapF.add (m, lv, lv')          let val nlv = cplv lv in (nlv, M.add(alpha,lv,nlv)) end
98         in (lv', m')      fun newvs (lvs,alpha) =
99        end          foldr (fn (lv,(lvs,alpha)) =>
100                   let val (nlv,nalpha) = newv(lv,alpha) in (nlv::lvs,nalpha) end)
101      fun renamevs (vs, m) =                ([],alpha) lvs
102        let fun h([], nvs, nm) = (rev nvs, nm)      fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
103              | h(a::r, nvs, nm) =          (s, Access.EXN(Access.LVAR(substvar lv)), lty)
104                   let val (a', nm') = rename(a, nm)        | cdcon dc = dc
105                    in h(r, a'::nvs, nm')      fun cpo (SOME{default,table},po,lty,tycs) =
106                   end          (SOME{default=substvar default,
107         in h(vs, [], m)                table=map (fn (tycs,lv) => (tycs, substvar lv)) table},
108        end           po,lty,tycs)
109          | cpo po = po
110      fun renamevps (vps, m) =  in case le
111        let fun h([], nvs, nm) = (rev nvs, nm)      of RET vs => RET(map substval vs)
112              | h((a,t)::r, nvs, nm) =       | LET (lvs,le,body) =>
113                   let val (a', nm') = rename(a, nm)         let val nle = copy alpha le
114                    in h(r, (a',t)::nvs, nm')             val (nlvs,nalpha) = newvs(lvs,alpha)
115                   end         in LET(nlvs, nle, copy nalpha body)
116         in h(vps, [], m)         end
117        end       | FIX (fdecs,le) =>
118           let fun cfun alpha ((fk,f,args,body):fundec,nf) =
119      (* access *)                 let val (nargs,nalpha) = newvs(map #1 args, alpha)
120      fun ca (DA.LVAR v, m) = DA.LVAR (look m v)                 in (fk, nf, ListPair.zip(nargs, (map #2 args)), copy nalpha body)
       | 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  
   
     (* dataconstr *)  
     fun cdc ((s, cr, t), m) = (s, ccr (cr, m), t)  
   
     (* con *)  
     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  
   
     (* primop *)  
     fun cprim (p as (NONE, _, _, _), m) = p  
       | cprim ((SOME d, p, lt, ts), m) = (SOME (dict(d, m)), p, lt, ts)  
   
     (* value *)  
     fun sv (VAR lv, m) = VAR (look m lv)  
       | sv (x as INT _, _) = x  
       | sv (x as INT32 _, _) = x  
       | sv (x as WORD _, _) = x  
       | sv (x as WORD32 _, _) = x  
       | sv (x as REAL _, _) = x  
       | sv (x as STRING _, _) = x  
   
     (* value list *)  
     fun svs (vs, m) =  
       let fun h([], res, m) = rev res  
             | h(v::r, res, m) = h(r, (sv(v, m))::res, m)  
        in h(vs, [], m)  
       end  
   
     (* lexp *)  
     fun c (RET vs, m) = RET (svs (vs, m))  
       | c (APP (v, vs), m) = APP (sv (v, m), svs (vs, m))  
       | c (TAPP (v, ts), m) = TAPP (sv (v, m), ts)  
       | c (FIX (fdecs, le), m) =  
            let val (fdecs', nm) = cf(fdecs, m)  
             in FIX(fdecs', c(le, nm))  
            end  
       | c (LET (vs, le1, le2), m) =  
            let val le1' = c(le1, m)  
                val (nvs, m') = renamevs(vs, m)  
             in LET(nvs, le1', c(le2, m'))  
            end  
       | c (TFN (tfdec, le), m) =  
            let val (tfdec', nm) = ctf(tfdec, m)  
             in TFN(tfdec', c(le, nm))  
            end  
   
       | c (SWITCH (v, crl, cel, eo), m) =  
            let fun cc (con, x) =  
                  let val (ncon, m') = ccon (con, m)  
                   in (ncon, c (x, m'))  
                  end  
                fun co NONE = NONE  
                  | co (SOME x) = SOME (c (x, m))  
             in SWITCH (sv (v, m), crl, map cc cel, co eo)  
            end  
       | c (CON (dc, ts, u, v, le), m) =  
            let val (nv, nm) = rename(v, m)  
             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))  
121             end             end
122        | c (SELECT (u, i, v, le), m) =             val (nfs, nalpha) = newvs(map #2 fdecs, alpha)
123             let val (nv, nm) = rename(v, m)             val nfdecs = ListPair.map (cfun nalpha) (fdecs, nfs)
124              in SELECT (sv (u,m), i, nv, c(le, nm))         in
125               FIX(nfdecs, copy nalpha le)
126             end             end
127        | c (RAISE (v, ts), m) = RAISE (sv (v, m), ts)       | APP (f,args) => APP(substval f, map substval args)
128        | c (HANDLE (e, v), m) = HANDLE (c (e, m), sv (v, m))       | TFN ((lv,args,body),le) =>
129        | c (BRANCH (p, vs, e1, e2), m) =         (* don't forget to rename the tvar also *)
130             BRANCH (cprim(p, m), svs(vs, m), c(e1, m), c(e2, m))         let val (nlv,nalpha) = newv(lv,alpha)
131        | c (PRIMOP (p, vs, v, le), m) =             val (nargs,ialpha) = newvs(map #1 args, nalpha)
132             let val (nv, nm) = rename(v, m)         in TFN((nlv, ListPair.zip(nargs, map #2 args), copy ialpha body),
133              in PRIMOP(cprim(p,m), svs(vs, m), nv, c(le, nm))                  copy nalpha le)
134           end
135         | TAPP (f,tycs) => TAPP(substval f, tycs)
136         | SWITCH (v,ac,arms,def) =>
137           let fun carm (DATAcon(dc,tycs,lv),le) =
138                   let val (nlv,nalpha) = newv(lv, alpha)
139                   in (DATAcon(cdcon dc, tycs, nlv), copy nalpha le)
140                   end
141                 | carm (con,le) = (con, copy alpha le)
142           in SWITCH(substval v, ac, map carm arms, Option.map (copy alpha) def)
143           end
144         | CON (dc,tycs,v,lv,le) =>
145           let val (nlv,nalpha) = newv(lv, alpha)
146           in CON(cdcon dc, tycs, substval v, nlv, copy nalpha le)
147           end
148         | RECORD (rk,vs,lv,le) =>
149           let val (nlv,nalpha) = newv(lv, alpha)
150           in RECORD(rk, map substval vs, nlv, copy nalpha le)
151           end
152         | SELECT (v,i,lv,le) =>
153           let val (nlv,nalpha) = newv(lv, alpha)
154           in SELECT(substval v, i, nlv, copy nalpha le)
155           end
156         | RAISE (v,ltys) => RAISE(substval v, ltys)
157         | HANDLE (le,v) => HANDLE(copy alpha le, substval v)
158         | BRANCH (po,vs,le1,le2) =>
159           BRANCH(cpo po, map substval vs, copy alpha le1, copy alpha le2)
160         | PRIMOP (po,vs,lv,le) =>
161           let val (nlv,nalpha) = newv(lv, alpha)
162           in PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)
163             end             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)  
164        end        end
165    
     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, [])  
       end  
 in  
     fn fdec =>  
       let val init = IntmapF.empty  
           val (fdecs', _) = cf([fdec], init)  
        in (case fdecs'  
             of [x] => x  
              | _ => bug "unexpected cases in copy - top")  
       end  
 end (* function copy *)  
166    
167  end (* top-level local *)  end (* top-level local *)
168  end (* structure FlintUtil *)  end (* structure FlintUtil *)

Legend:
Removed from v.153  
changed lines
  Added in v.154

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