Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/cps/cpstrans.sml

Parent Directory | Revision Log

---

Revision 16 - (view) (download)
Original Path: sml/trunk/src/compiler/FLINT/cps/cpstrans.sml

1 :	monnier	16	(* Copyright 1996 by Bell Laboratories *)
2 :			(* cpstrans.sml *)
3 :
4 :			signature CPSTRANS = sig
5 :			val cpstrans : CPS.function -> CPS.function
6 :			end (* signature CPSTRANS *)
7 :
8 :			functor CPStrans(MachSpec : MACH_SPEC) : CPSTRANS = struct
9 :
10 :			local open CPS
11 :			structure LV = LambdaVar
12 :			in
13 :
14 :			fun cpstrans fe = let
15 :
16 :			val unboxedfloat = MachSpec.unboxedFloats
17 :			val untaggedint = MachSpec.untaggedInt
18 :
19 :			exception CPSSUBST
20 :			val M : value Intmap.intmap = Intmap.new(32,CPSSUBST)
21 :			val addvl = Intmap.add M
22 :			fun mapvl v = ((Intmap.map M v) handle CPSSUBST => VAR v)
23 :
24 :			exception CTYMAP
25 :			val CT : cty Intmap.intmap = Intmap.new(32,CTYMAP)
26 :			val addty = Intmap.add CT
27 :			val getty = Intmap.map CT
28 :			fun grabty(VAR v) = ((getty v) handle _ => BOGt)
29 :			| grabty(REAL _) = FLTt
30 :			| grabty(INT _) = INTt
31 :			| grabty(INT32 _) = INT32t
32 :			| grabty _ = BOGt
33 :
34 :
35 :			fun select(i,u,x,ct,ce) = SELECT(i,u,x,ct,ce)
36 :			fun record(k,ul,w,ce) = RECORD(k,ul,w,ce)
37 :
38 :			(* wrappers around floats and ints are now dealt with in the convert phase *)
39 :			(***>>
40 :			fun unwrapfloat(u,x,ce) = PURE(P.funwrap,[u],x,FLTt,ce)
41 :			fun wrapfloat(u,x,ce) = PURE(P.fwrap,[u],x,BOGt,ce)
42 :			fun unwrapint(u,x,ce) = PURE(P.iunwrap,[u],x,INTt,ce)
43 :			fun wrapint(u,x,ce) = PURE(P.iwrap,[u],x,BOGt,ce)
44 :			fun unwrapint32(u,x,ce) = PURE(P.i32unwrap,[u],x,INT32t,ce)
45 :			fun wrapint32(u,x,ce) = PURE(P.i32wrap,[u],x,BOGt,ce)
46 :
47 :			fun select(i,u,x,ct,ce) =
48 :			case (ct,unboxedfloat,untaggedint)
49 :			of (FLTt,true,_) => let val v = LV.mkLvar()
50 :			in SELECT(i,u,v,BOGt,unwrapfloat(VAR v,x,ce))
51 :			end
52 :			| (INTt,_,true) => let val v = LV.mkLvar()
53 :			in SELECT(i,u,v,BOGt,unwrapint(VAR v,x,ce))
54 :			end
55 :			| (INT32t,_,_) => let val v = LV.mkLvar()
56 :			in SELECT(i,u,v,BOGt,unwrapint32(VAR v,x,ce))
57 :			end
58 :			| _ => SELECT(i,u,x,ct,ce)
59 :
60 :			fun record(k,ul,w,ce) =
61 :			let fun h((FLTt,u),(l,h)) =
62 :			if unboxedfloat then
63 :			(let val v = LV.mkLvar()
64 :			in ((VAR v,OFFp 0)::l, fn ce => wrapfloat(#1 u,v,h(ce)))
65 :			end)
66 :			else (u::l,h)
67 :			| h((INTt,u),(l,h)) =
68 :			if untaggedint then
69 :			(let val v = LV.mkLvar()
70 :			in ((VAR v,OFFp 0)::l, fn ce => wrapint(#1 u,v,h(ce)))
71 :			end)
72 :			else (u::l,h)
73 :			| h((INT32t,u),(l,h)) =
74 :			let val v = LV.mkLvar()
75 :			in ((VAR v,OFFp 0)::l, fn ce => wrapint32(#1 u,v,h(ce)))
76 :			end
77 :			| h((_,u),(l,h)) = (u::l,h)
78 :
79 :			val info = map (fn (u as (v,_)) => (grabty v,u)) ul
80 :			val (nul,header) = fold h info ([],fn x => x)
81 :			in header(RECORD(k,nul,w,ce))
82 :			end
83 :			<<***)
84 :
85 :			fun cexptrans(ce) =
86 :			case ce
87 :			of RECORD(k,vl,w,ce) => record(k,map rectrans vl,w,cexptrans ce)
88 :			| SELECT(i,v,w,t,ce) =>
89 :			(let val _ = addty(w,t)
90 :			val v' = vtrans v
91 :			val ce' = cexptrans ce
92 :			in select(i, v', w, getty w, ce')
93 :			end)
94 :			| OFFSET(i,v,w,ce) => OFFSET(i, vtrans v, w, cexptrans ce)
95 :			| APP(v,vl) => APP(vtrans v, map vtrans vl)
96 :			| FIX(l,ce) => FIX(map functrans l, cexptrans ce)
97 :			| SWITCH(v,c,l) => SWITCH(vtrans v,c,map cexptrans l)
98 :			| LOOKER(p,vl,w,t,ce) =>
99 :			(let val _ = addty(w,t)
100 :			val vl' = map vtrans vl
101 :			val ce' = cexptrans ce
102 :			in LOOKER(p, vl', w, getty w, ce')
103 :			end)
104 :			| SETTER(p,vl,ce) =>
105 :			SETTER(p, map vtrans vl, cexptrans ce)
106 :			| ARITH(p,vl,w,t,ce) =>
107 :			(addty(w,t); ARITH(p, map vtrans vl, w, t, cexptrans ce))
108 :
109 :
110 :			(*** this special case is a temporary hack; ask ZHONG for details *)
111 :			(*
112 :			| PURE(P.wrap,[u],w,t as PTRt(FPT _),ce) =>
113 :			(addty(w, t); PURE(P.wrap, [vtrans u], w, t, cexptrans ce))
114 :			| PURE(P.unwrap,[u],w,t as PTRt(FPT _),ce) =>
115 :			(addty(w, t); PURE(P.unwrap, [vtrans u], w, t, cexptrans ce))
116 :			*)
117 :
118 :			| PURE(P.wrap,[u],w,t,ce) =>
119 :			(addvl(w,vtrans u); cexptrans ce)
120 :			| PURE(P.unwrap,[u],w,t,ce) =>
121 :			(case u of VAR z => addty(z,t)
122 :			| _ => ();
123 :			addvl(w,vtrans u); cexptrans ce)
124 :			| PURE(P.fwrap,[u],w,t,ce) =>
125 :			if unboxedfloat
126 :			then (addty(w,t); PURE(P.fwrap,[vtrans u],w,t,cexptrans ce))
127 :			else (addvl(w,vtrans u); cexptrans ce)
128 :			| PURE(P.funwrap,[u],w,t,ce) =>
129 :			if unboxedfloat
130 :			then (addty(w,t); PURE(P.funwrap,[vtrans u],w,t,cexptrans ce))
131 :			else (addvl(w,vtrans u); cexptrans ce)
132 :			| PURE(P.iwrap,[u],w,t,ce) =>
133 :			if untaggedint
134 :			then (addty(w,t); PURE(P.iwrap,[vtrans u],w,t,cexptrans ce))
135 :			else (addvl(w,vtrans u); cexptrans ce)
136 :			| PURE(P.iunwrap,[u],w,t,ce) =>
137 :			if untaggedint
138 :			then (addty(w,t); PURE(P.iunwrap,[vtrans u],w,t,cexptrans ce))
139 :			else (addvl(w,vtrans u); cexptrans ce)
140 :			| PURE(P.i32wrap,[u],w,t,ce) =>
141 :			(addty(w,t); PURE(P.i32wrap,[vtrans u],w,t,cexptrans ce))
142 :			| PURE(P.i32unwrap,[u],w,t,ce) =>
143 :			(addty(w,t); PURE(P.i32unwrap,[vtrans u],w,t,cexptrans ce))
144 :			(*
145 :			| PURE(P.cast,[u],w,_,ce) =>
146 :			(addvl(w,vtrans u); cexptrans ce)
147 :			*)
148 :			| PURE(P.getcon,[u],w,t,ce) =>
149 :			(addty(w,t); select(0,vtrans u,w,t,cexptrans ce))
150 :			| PURE(P.getexn,[u],w,t,ce) =>
151 :			(addty(w,t); select(0,vtrans u,w,t,cexptrans ce))
152 :			| PURE(p,vl,w,t,ce) =>
153 :			(let val _ = addty(w,t)
154 :			val vl' = map vtrans vl
155 :			val ce' = cexptrans ce
156 :			in PURE(p, vl', w, getty w, ce')
157 :			end)
158 :			| BRANCH(p,vl,c,e1,e2) =>
159 :			BRANCH(p, map vtrans vl, c, cexptrans e1, cexptrans e2)
160 :
161 :			and functrans(fk,v,args,cl,ce) =
162 :			let val _ = ListPair.app addty (args,cl)
163 :			val ce' = cexptrans ce
164 :			in (fk,v,args,map getty args,ce')
165 :			end
166 :			and rectrans(v,acp) = (vtrans v,acp)
167 :			and vtrans(VAR v) = (mapvl v) | vtrans u = u
168 :
169 :			in functrans fe
170 :			end
171 :
172 :
173 :			end (* toplevel local *)
174 :			end (* structure CPStrans *)
175 :
176 :
177 :			(*
178 :			* $Log: cpstrans.sml,v $
179 :			* Revision 1.2 1998/01/07 15:10:59 dbm
180 :			* Fixing bug 1323. Wrapping and unwrapping primitives were usually ignored
181 :			* in the cpstrans phase before we perform the cps optimization. Unfortunately,
182 :			* they could lead to ill-typed CPS programs. To resolve this, I turn those
183 :			* sensitive wrap and unwrap primitives into "casts"; I leave the casts in the
184 :			* code; the cps generic phase will generate a move for each cast. In the
185 :			* long term, we have to think thoroughly about the meanings of these wrapping
186 :			* primitives and how they interface with compile-time optimizations.
187 :			*
188 :			* Revision 1.1.1.1 1997/01/14 01:38:30 george
189 :			* Version 109.24
190 :			*
191 :			*)

---

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