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

Parent Directory | Revision Log | 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 *)

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

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