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 44, Sun Mar 22 20:10:57 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 3  Line 3 
3    
4  signature FLINTUTIL =  signature FLINTUTIL =
5  sig  sig
6    val copy : (unit -> LambdaVar.lvar) -> FLINT.fundec -> FLINT.fundec    val rk_tuple : FLINT.rkind
7  end (* signature LEXPUTIL *)  
8      val mketag : FLINT.tyc -> FLINT.primop
9      val wrap   : FLINT.tyc -> FLINT.primop
10      val unwrap : FLINT.tyc -> FLINT.primop
11    
12      val WRAP   : FLINT.tyc * FLINT.value list
13                             * FLINT.lvar * FLINT.lexp -> FLINT.lexp
14      val UNWRAP : FLINT.tyc * FLINT.value list
15                             * FLINT.lvar * FLINT.lexp -> FLINT.lexp
16    
17      val getEtagTyc   : FLINT.primop -> FLINT.tyc
18      val getWrapTyc   : FLINT.primop -> FLINT.tyc
19      val getUnWrapTyc : FLINT.primop -> FLINT.tyc
20    
21      val copy : (unit -> FLINT.lvar) -> FLINT.prog -> FLINT.prog
22    end (* signature FLINTUTIL *)
23    
24    
25  structure FlintUtil : FLINTUTIL =  structure FlintUtil : FLINTUTIL =
26  struct  struct
27    
28  local structure EM = ErrorMsg  local structure EM = ErrorMsg
29        open Access FLINT        structure LT = LtyExtern
30        fun bug msg = EM.impossible("FlintUtil: "^msg)        structure PO = PrimOp
31          structure DA = Access
32          open FLINT
33  in  in
34    
35    fun bug msg = EM.impossible("FlintUtil: "^msg)
36    
37    val rk_tuple : rkind = RK_TUPLE (LT.rfc_tmp)
38    
39    (* a set of useful primops used by FLINT *)
40    val tv0 = LT.ltc_tv 0
41    val btv0 = LT.ltc_tyc(LT.tcc_box (LT.tcc_tv 0))
42    val etag_lty =
43      LT.ltc_ppoly ([LT.tkc_mono],
44                     LT.ltc_arrow(LT.ffc_rrflint, [LT.ltc_string],
45                                                  [LT.ltc_etag tv0]))
46    fun wrap_lty tc =
47      LT.ltc_tyc(LT.tcc_arrow(LT.ffc_fixed, [tc], [LT.tcc_wrap tc]))
48    fun unwrap_lty tc =
49      LT.ltc_tyc(LT.tcc_arrow(LT.ffc_fixed, [LT.tcc_wrap tc], [tc]))
50    
51    fun mketag tc = (NONE, PO.MKETAG, etag_lty, [tc])
52    fun wrap tc = (NONE, PO.WRAP, wrap_lty tc, [])
53    fun unwrap tc = (NONE, PO.UNWRAP, unwrap_lty tc, [])
54    
55    fun WRAP(tc, vs, v, e) = PRIMOP(wrap tc, vs, v, e)
56    fun UNWRAP(tc, vs, v, e) = PRIMOP(unwrap tc, vs, v, e)
57    
58    (* the corresponding utility functions to recover the tyc *)
59    fun getEtagTyc (_, _, lt, [tc]) = tc
60      | getEtagTyc (_, _, lt, []) =
61          let val (t, xs) = LT.tcd_app(LT.ltd_tyc (#2(LT.ltd_parrow lt)))
62           in (case xs of [x] => x
63                        | _ => bug "unexpected case 1 in getEtagTyc")
64          end
65      | getEtagTyc _ = bug "unexpected case 2 in getEtagTyc"
66    
67    fun getWrapTyc (_, _, lt, []) = LT.ltd_tyc(#1(LT.ltd_parrow lt))
68      | getWrapTyc _ = bug "unexpected case in getWrapTyc"
69    
70    fun getUnWrapTyc (_, _, lt, []) = LT.ltd_tyc(#2(LT.ltd_parrow lt))
71      | getUnWrapTyc _ = bug "unexpected case in getUnWrapTyc"
72    
73  (*  (*
74   * general alpha-conversion on lexp free variables remain unchanged   * general alpha-conversion on lexp free variables remain unchanged
75   *   val copy: (unit -> lvar) -> fundec -> fundec   *   val copy: (unit -> lvar) -> fundec -> fundec
# Line 47  Line 102 
102        end        end
103    
104      (* access *)      (* access *)
105      fun ca (LVAR v, m) = LVAR (look m v)      fun ca (DA.LVAR v, m) = DA.LVAR (look m v)
106        | ca (PATH (a, i), m) = PATH (ca (a, m), i)        | ca (DA.PATH (a, i), m) = DA.PATH (ca (a, m), i)
107        | ca (a, _) = a        | ca (a, _) = a
108    
109      (* conrep *)      (* conrep *)
110      fun ccr (EXN a, m) = EXN (ca (a, m))      fun ccr (DA.EXN a, m) = DA.EXN (ca (a, m))
111        | ccr (cr, _) = cr        | ccr (cr, _) = cr
112    
113      (* dataconstr *)      (* dataconstr *)
114      fun cdc ((s, cr, t), m) = (s, ccr (cr, m), t)      fun cdc ((s, cr, t), m) = (s, ccr (cr, m), t)
115    
116      (* con *)      (* con *)
117      fun ccon (DATAcon (dc, ts, vs), m) =      fun ccon (DATAcon (dc, ts, v), m) =
118            let val (nvs, m') = renamevs(vs, m)            let val (nv, m') = rename(v, m)
119             in (DATAcon (cdc(dc, m), ts, nvs), m')             in (DATAcon (cdc(dc, m), ts, nv), m')
120            end            end
121        | ccon x = x        | ccon x = x
122    
# Line 72  Line 127 
127         in {default=nv, table=ntbls}         in {default=nv, table=ntbls}
128        end        end
129    
130        (* primop *)
131        fun cprim (p as (NONE, _, _, _), m) = p
132          | cprim ((SOME d, p, lt, ts), m) = (SOME (dict(d, m)), p, lt, ts)
133    
134      (* value *)      (* value *)
135      fun sv (VAR lv, m) = VAR (look m lv)      fun sv (VAR lv, m) = VAR (look m lv)
136        | sv (x as INT _, _) = x        | sv (x as INT _, _) = x
# Line 115  Line 174 
174                   | co (SOME x) = SOME (c (x, m))                   | co (SOME x) = SOME (c (x, m))
175              in SWITCH (sv (v, m), crl, map cc cel, co eo)              in SWITCH (sv (v, m), crl, map cc cel, co eo)
176             end             end
177        | c (CON (dc, ts, vs, v, le), m) =        | c (CON (dc, ts, u, v, le), m) =
178             let val (nv, nm) = rename(v, m)             let val (nv, nm) = rename(v, m)
179              in CON (cdc (dc, m), ts, svs (vs, m), nv, c(le, nm))              in CON (cdc (dc, m), ts, sv (u, m), nv, c(le, nm))
180             end             end
181        | c (RECORD (rk, vs, v, le), m) =        | c (RECORD (rk, vs, v, le), m) =
182             let val (nv, nm) = rename(v, m)             let val (nv, nm) = rename(v, m)
# Line 129  Line 188 
188             end             end
189        | c (RAISE (v, ts), m) = RAISE (sv (v, m), ts)        | c (RAISE (v, ts), m) = RAISE (sv (v, m), ts)
190        | c (HANDLE (e, v), m) = HANDLE (c (e, m), sv (v, m))        | c (HANDLE (e, v), m) = HANDLE (c (e, m), sv (v, m))
191        | c (ETAG (t, u, v, le), m) =        | c (BRANCH (p, vs, e1, e2), m) =
192             let val (nv, nm) = rename(v, m)             BRANCH (cprim(p, m), svs(vs, m), c(e1, m), c(e2, m))
             in ETAG (t, sv(u, m), nv, c(le, nm))  
            end  
193        | c (PRIMOP(p, vs, v, le), m) =        | c (PRIMOP(p, vs, v, le), m) =
194             let val (nv, nm) = rename(v, m)             let val (nv, nm) = rename(v, m)
195              in PRIMOP(p, svs(vs, m), nv, c(le, nm))              in PRIMOP(cprim(p,m), svs(vs, m), nv, c(le, nm))
            end  
       | c (GENOP(d, p, vs, v, le), m) =  
            let val (nv, nm) = rename(v, m)  
             in GENOP(dict(d, m), p, svs(vs, m), nv, c(le, nm))  
            end  
       | c (WRAP (t, u, v, le), m) =  
            let val (nv, nm) = rename(v, m)  
             in WRAP (t, sv (u, m), nv, c(le, nm))  
            end  
       | c (UNWRAP (t, u, v, le), m) =  
            let val (nv, nm) = rename(v, m)  
             in UNWRAP (t, sv (u, m), nv, c(le, nm))  
196             end             end
197    
198      and ctf ((v,args,le), m) =      and ctf ((v,args,le), m) =

Legend:
Removed from v.44  
changed lines
  Added in v.45

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