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/branches/SMLNJ/src/compiler/FLINT/cps/cpstrans.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (view) (download)

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