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 17, Wed Mar 11 21:00:18 1998 UTC revision 24, Thu Mar 12 00:49:58 1998 UTC
# Line 3  Line 3 
3    
4  signature FLINTUTIL =  signature FLINTUTIL =
5  sig  sig
6    val rk_tuple : FLINT.rkind    val copy : (unit -> LambdaVar.lvar) -> FLINT.fundec -> FLINT.fundec
7    end (* signature LEXPUTIL *)
   val mketag : FLINT.tyc -> FLINT.primop  
   val wrap   : FLINT.tyc -> FLINT.primop  
   val unwrap : FLINT.tyc -> FLINT.primop  
   
   val WRAP   : FLINT.tyc * FLINT.value list  
                          * FLINT.lvar * FLINT.lexp -> FLINT.lexp  
   val UNWRAP : FLINT.tyc * FLINT.value list  
                          * FLINT.lvar * FLINT.lexp -> FLINT.lexp  
   
   val getEtagTyc   : FLINT.primop -> FLINT.tyc  
   val getWrapTyc   : FLINT.primop -> FLINT.tyc  
   val getUnWrapTyc : FLINT.primop -> FLINT.tyc  
   
   val copy : (unit -> FLINT.lvar) -> FLINT.prog -> FLINT.prog  
 end (* signature FLINTUTIL *)  
8    
9    
10  structure FlintUtil : FLINTUTIL =  structure FlintUtil : FLINTUTIL =
11  struct  struct
12    
13  local structure EM = ErrorMsg  local structure EM = ErrorMsg
14        structure LT = LtyExtern        open Access FLINT
       structure PO = PrimOp  
       structure DA = Access  
       open FLINT  
 in  
   
15  fun bug msg = EM.impossible("FlintUtil: "^msg)  fun bug msg = EM.impossible("FlintUtil: "^msg)
16    in
 val rk_tuple : rkind = RK_TUPLE (LT.default_rflag)  
   
 (* a set of useful primops used by FLINT *)  
 val tv0 = LT.ltc_tv 0  
 val btv0 = LT.ltc_tyc(LT.tcc_box (LT.tcc_tv 0))  
 val etag_lty =  
   LT.ltc_ppoly ([LT.tkc_mono],  
         LT.ltc_arrow(LT.default_fflag, [LT.ltc_string], [LT.ltc_etag tv0]))  
 fun wrap_lty tc =  
   LT.ltc_tyc(LT.tcc_arrow(LT.default_fflag, [tc], [LT.tcc_box tc]))  
 fun unwrap_lty tc =  
   LT.ltc_tyc(LT.tcc_arrow(LT.default_fflag, [LT.tcc_box tc], [tc]))  
   
 fun mketag tc = (NONE, PO.MKETAG, etag_lty, [tc])  
 fun wrap tc = (NONE, PO.WRAP, wrap_lty tc, [])  
 fun unwrap tc = (NONE, PO.WRAP, unwrap_lty tc, [])  
   
 fun WRAP(tc, vs, v, e) = PRIMOP(wrap tc, vs, v, e)  
 fun UNWRAP(tc, vs, v, e) = PRIMOP(unwrap tc, vs, v, e)  
   
 (* the corresponding utility functions to recover the tyc *)  
 fun getEtagTyc (_, _, lt, [tc]) = tc  
   | getEtagTyc _ = bug "unexpected case 2 in getEtagTyc"  
   
 fun getWrapTyc (_, _, lt, []) = LT.ltd_tyc(#1(LT.ltd_parrow lt))  
   | getWrapTyc _ = bug "unexpected case in getWrapTyc"  
   
 fun getUnWrapTyc (_, _, lt, []) = LT.ltd_tyc(#2(LT.ltd_parrow lt))  
   | getUnWrapTyc _ = bug "unexpected case in getUnWrapTyc"  
17    
18  (*  (*
19   * general alpha-conversion on lexp free variables remain unchanged   * general alpha-conversion on lexp free variables remain unchanged
# Line 96  Line 47 
47        end        end
48    
49      (* access *)      (* access *)
50      fun ca (DA.LVAR v, m) = DA.LVAR (look m v)      fun ca (LVAR v, m) = LVAR (look m v)
51        | ca (DA.PATH (a, i), m) = DA.PATH (ca (a, m), i)        | ca (PATH (a, i), m) = PATH (ca (a, m), i)
52        | ca (a, _) = a        | ca (a, _) = a
53    
54      (* conrep *)      (* conrep *)
55      fun ccr (DA.EXN a, m) = DA.EXN (ca (a, m))      fun ccr (EXN a, m) = EXN (ca (a, m))
56        | ccr (cr, _) = cr        | ccr (cr, _) = cr
57    
58      (* dataconstr *)      (* dataconstr *)
59      fun cdc ((s, cr, t), m) = (s, ccr (cr, m), t)      fun cdc ((s, cr, t), m) = (s, ccr (cr, m), t)
60    
61      (* con *)      (* con *)
62      fun ccon (DATAcon (dc, ts, v), m) =      fun ccon (DATAcon (dc, ts, vs), m) =
63            let val (nv, m') = rename(v, m)            let val (nvs, m') = renamevs(vs, m)
64             in (DATAcon (cdc(dc, m), ts, nv), m')             in (DATAcon (cdc(dc, m), ts, nvs), m')
65            end            end
66        | ccon x = x        | ccon x = x
67    
# Line 121  Line 72 
72         in {default=nv, table=ntbls}         in {default=nv, table=ntbls}
73        end        end
74    
     (* primop *)  
     fun cprim (p as (NONE, _, _, _), m) = p  
       | cprim ((SOME d, p, lt, ts), m) = (SOME (dict(d, m)), p, lt, ts)  
   
75      (* value *)      (* value *)
76      fun sv (VAR lv, m) = VAR (look m lv)      fun sv (VAR lv, m) = VAR (look m lv)
77        | sv (x as INT _, _) = x        | sv (x as INT _, _) = x
# Line 168  Line 115 
115                   | co (SOME x) = SOME (c (x, m))                   | co (SOME x) = SOME (c (x, m))
116              in SWITCH (sv (v, m), crl, map cc cel, co eo)              in SWITCH (sv (v, m), crl, map cc cel, co eo)
117             end             end
118        | c (CON (dc, ts, u, v, le), m) =        | c (CON (dc, ts, vs, v, le), m) =
119             let val (nv, nm) = rename(v, m)             let val (nv, nm) = rename(v, m)
120              in CON (cdc (dc, m), ts, sv (u, m), nv, c(le, nm))              in CON (cdc (dc, m), ts, svs (vs, m), nv, c(le, nm))
121             end             end
122        | c (RECORD (rk, vs, v, le), m) =        | c (RECORD (rk, vs, v, le), m) =
123             let val (nv, nm) = rename(v, m)             let val (nv, nm) = rename(v, m)
# Line 182  Line 129 
129             end             end
130        | c (RAISE (v, ts), m) = RAISE (sv (v, m), ts)        | c (RAISE (v, ts), m) = RAISE (sv (v, m), ts)
131        | c (HANDLE (e, v), m) = HANDLE (c (e, m), sv (v, m))        | c (HANDLE (e, v), m) = HANDLE (c (e, m), sv (v, m))
132        | c (BRANCH (p, vs, e1, e2), m) =        | c (ETAG (t, u, v, le), m) =
133             BRANCH (cprim(p, m), svs(vs, m), c(e1, m), c(e2, m))             let val (nv, nm) = rename(v, m)
134                in ETAG (t, sv(u, m), nv, c(le, nm))
135               end
136        | c (PRIMOP (p, vs, v, le), m) =        | c (PRIMOP (p, vs, v, le), m) =
137             let val (nv, nm) = rename(v, m)             let val (nv, nm) = rename(v, m)
138              in PRIMOP(cprim(p,m), svs(vs, m), nv, c(le, nm))              in PRIMOP(p, svs(vs, m), nv, c(le, nm))
139               end
140          | c (GENOP(d, p, vs, v, le), m) =
141               let val (nv, nm) = rename(v, m)
142                in GENOP(dict(d, m), p, svs(vs, m), nv, c(le, nm))
143               end
144          | c (WRAP (t, u, v, le), m) =
145               let val (nv, nm) = rename(v, m)
146                in WRAP (t, sv (u, m), nv, c(le, nm))
147               end
148          | c (UNWRAP (t, u, v, le), m) =
149               let val (nv, nm) = rename(v, m)
150                in UNWRAP (t, sv (u, m), nv, c(le, nm))
151             end             end
152    
153      and ctf ((v,args,le), m) =      and ctf ((v,args,le), m) =

Legend:
Removed from v.17  
changed lines
  Added in v.24

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