Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/FLINT/flint/flintutil.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 197 - (view) (download)

1 : monnier 16 (* Copyright 1997 (c) by YALE FLINT PROJECT *)
2 :     (* flintutil.sml *)
3 :    
4 :     signature FLINTUTIL =
5 :     sig
6 : monnier 45 val rk_tuple : FLINT.rkind
7 : monnier 16
8 : monnier 45 val mketag : FLINT.tyc -> FLINT.primop
9 :     val wrap : FLINT.tyc -> FLINT.primop
10 :     val unwrap : FLINT.tyc -> FLINT.primop
11 : monnier 16
12 : monnier 45 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 : monnier 154 (* copy a lexp with alpha renaming.
22 :     * free variables remain unchanged except for the renaming specified
23 : monnier 197 * in the first (types) and second (values) argument *)
24 :     val copy : (FLINT.tvar * FLINT.tyc) list ->
25 :     FLINT.lvar IntmapF.intmap ->
26 :     FLINT.lexp -> FLINT.lexp
27 : monnier 154
28 :     val dcon_eq : FLINT.dcon * FLINT.dcon -> bool
29 :    
30 : monnier 45 end (* signature FLINTUTIL *)
31 :    
32 :    
33 : monnier 16 structure FlintUtil : FLINTUTIL =
34 :     struct
35 :    
36 :     local structure EM = ErrorMsg
37 : monnier 45 structure LT = LtyExtern
38 :     structure PO = PrimOp
39 :     structure DA = Access
40 : monnier 154 structure M = IntmapF
41 : monnier 197 structure A = Access
42 :     structure O = Option
43 : monnier 45 open FLINT
44 : monnier 16 in
45 :    
46 : monnier 45 fun bug msg = EM.impossible("FlintUtil: "^msg)
47 :    
48 :     val rk_tuple : rkind = RK_TUPLE (LT.rfc_tmp)
49 :    
50 :     (* a set of useful primops used by FLINT *)
51 :     val tv0 = LT.ltc_tv 0
52 :     val btv0 = LT.ltc_tyc(LT.tcc_box (LT.tcc_tv 0))
53 :     val etag_lty =
54 :     LT.ltc_ppoly ([LT.tkc_mono],
55 :     LT.ltc_arrow(LT.ffc_rrflint, [LT.ltc_string],
56 :     [LT.ltc_etag tv0]))
57 :     fun wrap_lty tc =
58 :     LT.ltc_tyc(LT.tcc_arrow(LT.ffc_fixed, [tc], [LT.tcc_wrap tc]))
59 :     fun unwrap_lty tc =
60 :     LT.ltc_tyc(LT.tcc_arrow(LT.ffc_fixed, [LT.tcc_wrap tc], [tc]))
61 :    
62 :     fun mketag tc = (NONE, PO.MKETAG, etag_lty, [tc])
63 :     fun wrap tc = (NONE, PO.WRAP, wrap_lty tc, [])
64 :     fun unwrap tc = (NONE, PO.UNWRAP, unwrap_lty tc, [])
65 :    
66 :     fun WRAP(tc, vs, v, e) = PRIMOP(wrap tc, vs, v, e)
67 :     fun UNWRAP(tc, vs, v, e) = PRIMOP(unwrap tc, vs, v, e)
68 :    
69 :     (* the corresponding utility functions to recover the tyc *)
70 :     fun getEtagTyc (_, _, lt, [tc]) = tc
71 :     | getEtagTyc (_, _, lt, []) =
72 : monnier 69 let val nt = LT.ltd_tyc (#2(LT.ltd_parrow lt))
73 :     in if LT.tcp_app nt then
74 :     (case #2 (LT.tcd_app nt)
75 :     of [x] => x
76 :     | _ => bug "unexpected case 1 in getEtagTyc")
77 :     else LT.tcc_void
78 : monnier 45 end
79 :     | getEtagTyc _ = bug "unexpected case 2 in getEtagTyc"
80 :    
81 :     fun getWrapTyc (_, _, lt, []) = LT.ltd_tyc(#1(LT.ltd_parrow lt))
82 :     | getWrapTyc _ = bug "unexpected case in getWrapTyc"
83 :    
84 :     fun getUnWrapTyc (_, _, lt, []) = LT.ltd_tyc(#2(LT.ltd_parrow lt))
85 :     | getUnWrapTyc _ = bug "unexpected case in getUnWrapTyc"
86 :    
87 : monnier 154 fun dcon_eq ((s1,c1,t1),(s2,c2,t2)) =
88 :     (s1 = s2) andalso (c1 = c2) andalso LtyBasic.lt_eqv(t1, t2)
89 :    
90 :     val cplv = LambdaVar.dupLvar
91 : monnier 16 (*
92 :     * general alpha-conversion on lexp free variables remain unchanged
93 : monnier 154 * except for the renaming specified in the first argument.
94 :     * val copy: lvar M.intmap -> fundec -> fundec
95 : monnier 16 *)
96 : monnier 197 fun copy ta alpha le = let
97 :    
98 :     val tc_subst = LT.tc_nvar_subst_gen()
99 :     val lt_subst = LT.lt_nvar_subst_gen()
100 :    
101 :     fun substvar alpha lv = ((M.lookup alpha lv) handle M.IntmapF => lv)
102 :     fun substval alpha (VAR lv) = VAR(substvar alpha lv)
103 :     | substval alpha v = v
104 : monnier 154 fun newv (lv,alpha) =
105 :     let val nlv = cplv lv in (nlv, M.add(alpha,lv,nlv)) end
106 :     fun newvs (lvs,alpha) =
107 :     foldr (fn (lv,(lvs,alpha)) =>
108 :     let val (nlv,nalpha) = newv(lv,alpha) in (nlv::lvs,nalpha) end)
109 :     ([],alpha) lvs
110 : monnier 197 fun cdcon ta alpha (s,ac,lty) =
111 :     (s,
112 :     case ac
113 :     of A.EXN(A.LVAR lv) => A.EXN(A.LVAR(substvar alpha lv))
114 :     | _ => ac,
115 :     lt_subst ta lty)
116 :     fun cpo ta alpha (dict,po,lty,tycs) =
117 :     (O.map (fn {default,table} =>
118 :     {default=substvar alpha default,
119 :     table=map (fn (tycs,lv) =>
120 :     (map (tc_subst ta) tycs, substvar alpha lv))
121 :     table}) dict,
122 :     po, lt_subst ta lty, map (tc_subst ta) tycs)
123 :     fun cfk ta {isrec=SOME(ltys,lk),known,inline,cconv} =
124 :     {isrec=SOME(map (lt_subst ta) ltys,lk),
125 :     known=known, inline=inline, cconv=cconv}
126 :     | cfk _ fk = fk
127 :    
128 :     fun crk ta (RK_VECTOR tyc) = RK_VECTOR(tc_subst ta tyc)
129 :     | crk _ rk = rk
130 :    
131 :     fun copy' ta alpha le = let
132 :     val cpo = cpo ta alpha
133 :     val cdcon = cdcon ta alpha
134 :     val substvar = substvar alpha
135 :     val substval = substval alpha
136 :     val copy = copy' ta
137 :     in case le
138 : monnier 154 of RET vs => RET(map substval vs)
139 :     | LET (lvs,le,body) =>
140 :     let val nle = copy alpha le
141 :     val (nlvs,nalpha) = newvs(lvs,alpha)
142 :     in LET(nlvs, nle, copy nalpha body)
143 :     end
144 :     | FIX (fdecs,le) =>
145 :     let fun cfun alpha ((fk,f,args,body):fundec,nf) =
146 :     let val (nargs,nalpha) = newvs(map #1 args, alpha)
147 : monnier 197 in (cfk ta fk, nf,
148 :     ListPair.zip(nargs, (map (lt_subst ta o #2) args)),
149 :     copy nalpha body)
150 : monnier 154 end
151 :     val (nfs, nalpha) = newvs(map #2 fdecs, alpha)
152 :     val nfdecs = ListPair.map (cfun nalpha) (fdecs, nfs)
153 :     in
154 :     FIX(nfdecs, copy nalpha le)
155 :     end
156 :     | APP (f,args) => APP(substval f, map substval args)
157 :     | TFN ((lv,args,body),le) =>
158 :     (* don't forget to rename the tvar also *)
159 :     let val (nlv,nalpha) = newv(lv,alpha)
160 :     val (nargs,ialpha) = newvs(map #1 args, nalpha)
161 : monnier 197 val ita = (ListPair.map (fn (t,nt) => (t, LT.tcc_nvar nt))
162 :     (map #1 args, nargs)) @ ta
163 :     in TFN((nlv, ListPair.zip(nargs, map #2 args), copy' ita ialpha body),
164 : monnier 154 copy nalpha le)
165 :     end
166 : monnier 197 | TAPP (f,tycs) => TAPP(substval f, map (tc_subst ta) tycs)
167 : monnier 154 | SWITCH (v,ac,arms,def) =>
168 :     let fun carm (DATAcon(dc,tycs,lv),le) =
169 :     let val (nlv,nalpha) = newv(lv, alpha)
170 : monnier 197 in (DATAcon(cdcon dc, map (tc_subst ta) tycs, nlv),
171 :     copy nalpha le)
172 : monnier 154 end
173 :     | carm (con,le) = (con, copy alpha le)
174 :     in SWITCH(substval v, ac, map carm arms, Option.map (copy alpha) def)
175 :     end
176 :     | CON (dc,tycs,v,lv,le) =>
177 :     let val (nlv,nalpha) = newv(lv, alpha)
178 : monnier 197 in CON(cdcon dc, map (tc_subst ta) tycs, substval v, nlv, copy nalpha le)
179 : monnier 154 end
180 :     | RECORD (rk,vs,lv,le) =>
181 :     let val (nlv,nalpha) = newv(lv, alpha)
182 : monnier 197 in RECORD(crk ta rk, map substval vs, nlv, copy nalpha le)
183 : monnier 154 end
184 :     | SELECT (v,i,lv,le) =>
185 :     let val (nlv,nalpha) = newv(lv, alpha)
186 :     in SELECT(substval v, i, nlv, copy nalpha le)
187 :     end
188 : monnier 197 | RAISE (v,ltys) => RAISE(substval v, map (lt_subst ta) ltys)
189 : monnier 154 | HANDLE (le,v) => HANDLE(copy alpha le, substval v)
190 :     | BRANCH (po,vs,le1,le2) =>
191 :     BRANCH(cpo po, map substval vs, copy alpha le1, copy alpha le2)
192 :     | PRIMOP (po,vs,lv,le) =>
193 :     let val (nlv,nalpha) = newv(lv, alpha)
194 :     in PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)
195 :     end
196 : monnier 197 end
197 :     in copy' ta alpha le
198 : monnier 154 end
199 : monnier 16
200 :    
201 :     end (* top-level local *)
202 :     end (* structure FlintUtil *)
203 : monnier 93
204 :     (*
205 : monnier 113 * $Log$
206 : monnier 93 *)

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