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/cps/cps.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/cps/cps.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 418 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/cps/cps.sml

1 : monnier 245 (* Copyright 1996 by Bell Laboratories *)
2 :     (* cps.sml *)
3 :    
4 :     structure CPS = struct
5 :    
6 :     local structure PT = PrimTyc
7 :     fun bug s = ErrorMsg.impossible ("CPS:" ^ s)
8 :     in
9 :    
10 :     structure P = struct
11 :    
12 :     (* numkind includes kind and size *)
13 :     datatype numkind = INT of int | UINT of int | FLOAT of int
14 :    
15 :     datatype arithop = + | - | * | / | ~ | abs
16 :     | lshift | rshift | rshiftl | andb | orb | xorb | notb
17 :    
18 :     datatype cmpop = > | >= | < | <= | eql | neq
19 :    
20 :     (* fcmpop conforms to the IEEE std 754 predicates. *)
21 :     datatype fcmpop
22 :     = fEQ (* = *) | fULG (* ?<> *) | fUN (* ? *) | fLEG (* <=> *)
23 :     | fGT (* > *) | fGE (* >= *) | fUGT (* ?> *) | fUGE (* ?>= *)
24 :     | fLT (* < *) | fLE (* <= *) | fULT (* ?< *) | fULE (* ?<= *)
25 :     | fLG (* <> *) | fUE (* ?= *)
26 :    
27 :     (* These are two-way branches dependent on pure inputs *)
28 :     datatype branch
29 :     = cmp of {oper: cmpop, kind: numkind} (* numkind cannot be FLOAT *)
30 :     | fcmp of {oper: fcmpop, size: int}
31 :     | boxed | unboxed | peql | pneq
32 :     | streq | strneq
33 :     (* streq(n,a,b) is defined only if strings a and b have
34 :     exactly the same length n>1 *)
35 :    
36 :     (* These all update the store *)
37 :     datatype setter
38 :     = numupdate of {kind: numkind}
39 :     | unboxedupdate | boxedupdate | update
40 :     | unboxedassign | assign
41 :     | sethdlr | setvar | uselvar | setspecial
42 :     | free | acclink | setpseudo | setmark
43 :    
44 :     (* These fetch from the store, never have functions as arguments. *)
45 :     datatype looker
46 :     = ! | subscript | numsubscript of {kind: numkind} | getspecial | deflvar
47 :     | getrunvec | gethdlr | getvar | getpseudo
48 :    
49 :     (* These might raise exceptions, never have functions as arguments.*)
50 :     datatype arith
51 :     = arith of {oper: arithop, kind: numkind}
52 :     | test of int * int
53 :     | testu of int * int
54 :     | round of {floor: bool, fromkind: numkind, tokind: numkind}
55 :    
56 :     (* These don't raise exceptions and don't access the store. *)
57 :     datatype pure
58 :     = pure_arith of {oper: arithop, kind: numkind}
59 :     | pure_numsubscript of {kind: numkind}
60 :     | length | objlength | makeref
61 :     | extend of int * int | trunc of int * int | copy of int * int
62 :     | real of {fromkind: numkind, tokind: numkind}
63 :     | subscriptv
64 :     | gettag | mkspecial | wrap | unwrap | cast | getcon | getexn
65 :     | fwrap | funwrap | iwrap | iunwrap | i32wrap | i32unwrap
66 :     | getseqdata | recsubscript | raw64subscript | newarray0
67 :    
68 :     local
69 :     fun ioper (op > : cmpop) = (op <= : cmpop)
70 :     | ioper op <= = op >
71 :     | ioper op < = op >=
72 :     | ioper op >= = op <
73 :     | ioper eql = neq
74 :     | ioper neq = eql
75 :    
76 :     fun foper fEQ = fULG
77 :     | foper fULG = fEQ
78 :     | foper fGT = fULE
79 :     | foper fGE = fULT
80 :     | foper fLT = fUGE
81 :     | foper fLE = fUGT
82 :     | foper fLG = fUE
83 :     | foper fLEG = fUN
84 :     | foper fUGT = fLE
85 :     | foper fUGE = fLT
86 :     | foper fULT = fGE
87 :     | foper fULE = fGT
88 :     | foper fUE = fLG
89 :     | foper fUN = fLEG
90 :     in
91 :     fun opp boxed = unboxed
92 :     | opp unboxed = boxed
93 :     | opp strneq = streq
94 :     | opp streq = strneq
95 :     | opp peql = pneq
96 :     | opp pneq = peql
97 :     | opp (cmp{oper,kind}) = cmp{oper=ioper oper,kind=kind}
98 :     | opp (fcmp{oper,size}) = fcmp{oper=foper oper, size=size}
99 :     end
100 :    
101 :     val iadd = arith{oper=op +,kind=INT 31}
102 :     val isub = arith{oper=op -,kind=INT 31}
103 :     val imul = arith{oper=op *,kind=INT 31}
104 :     val idiv = arith{oper=op /,kind=INT 31}
105 :     val ineg = arith{oper=op ~,kind=INT 31}
106 :    
107 :     val fadd = arith{oper=op +,kind=FLOAT 64}
108 :     val fsub = arith{oper=op -,kind=FLOAT 64}
109 :     val fmul = arith{oper=op *,kind=FLOAT 64}
110 :     val fdiv = arith{oper=op /,kind=FLOAT 64}
111 :     val fneg = arith{oper=op ~,kind=FLOAT 64}
112 :    
113 :     val ieql = cmp{oper=eql,kind=INT 31}
114 :     val ineq = cmp{oper=neq,kind=INT 31}
115 :     val igt = cmp{oper=op >,kind=INT 31}
116 :     val ige = cmp{oper=op >=,kind=INT 31}
117 :     val ile = cmp{oper=op <=,kind=INT 31}
118 :     val ilt = cmp{oper=op <,kind=INT 31}
119 :     (* val iltu = cmp{oper=ltu, kind=INT 31}
120 :     val igeu = cmp{oper=geu,kind=INT 31}
121 :     *)
122 :     val feql =fcmp{oper=fEQ, size=64}
123 :     val fneq =fcmp{oper=fLG, size=64}
124 :     val fgt =fcmp{oper=fGT, size=64}
125 :     val fge =fcmp{oper=fGE, size=64}
126 :     val fle =fcmp{oper=fLE, size=64}
127 :     val flt =fcmp{oper=fLT, size=64}
128 :    
129 :     fun arity op ~ = 1
130 :     | arity _ = 2
131 :    
132 :     end (* P *)
133 :    
134 :     type lvar = LambdaVar.lvar
135 :    
136 :     datatype value
137 :     = VAR of lvar
138 :     | LABEL of lvar
139 :     | INT of int
140 :     | INT32 of Word32.word
141 :     | REAL of string
142 :     | STRING of string
143 :     | OBJECT of Unsafe.Object.object
144 :     | VOID
145 :    
146 :     datatype accesspath
147 :     = OFFp of int
148 :     | SELp of int * accesspath
149 :    
150 :     datatype fun_kind
151 :     = CONT (* continuation functions *)
152 :     | KNOWN (* general known functions *)
153 :     | KNOWN_REC (* known recursive functions *)
154 :     | KNOWN_CHECK (* known functions that need a heap limit check *)
155 :     | KNOWN_TAIL (* tail-recursive kernal *)
156 :     | KNOWN_CONT (* known continuation functions *)
157 :     | ESCAPE (* before the closure phase, any user function;
158 :     after the closure phase, escaping user function *)
159 :     | NO_INLINE_INTO (* before the closure phase,
160 :     a user function inside of which no in-line expansions
161 :     should be performed;
162 :     does not occur after the closure phase *)
163 :    
164 :     datatype record_kind
165 :     = RK_VECTOR
166 :     | RK_RECORD
167 :     | RK_SPILL
168 :     | RK_ESCAPE
169 :     | RK_EXN
170 :     | RK_CONT
171 :     | RK_FCONT
172 :     | RK_KNOWN
173 :     | RK_BLOCK
174 :     | RK_FBLOCK
175 :     | RK_I32BLOCK
176 :    
177 :     datatype pkind = VPT | RPT of int | FPT of int
178 :     datatype cty = INTt | INT32t | PTRt of pkind
179 :     | FUNt | FLTt | CNTt | DSPt
180 :    
181 :     datatype cexp
182 :     = RECORD of record_kind * (value * accesspath) list * lvar * cexp
183 :     | SELECT of int * value * lvar * cty * cexp
184 :     | OFFSET of int * value * lvar * cexp
185 :     | APP of value * value list
186 :     | FIX of function list * cexp
187 :     | SWITCH of value * lvar * cexp list
188 :     | BRANCH of P.branch * value list * lvar * cexp * cexp
189 :     | SETTER of P.setter * value list * cexp
190 :     | LOOKER of P.looker * value list * lvar * cty * cexp
191 :     | ARITH of P.arith * value list * lvar * cty * cexp
192 :     | PURE of P.pure * value list * lvar * cty * cexp
193 :     withtype function = fun_kind * lvar * lvar list * cty list * cexp
194 :    
195 :     fun combinepaths(p,OFFp 0) = p
196 :     | combinepaths(p,q) =
197 :     let val rec comb =
198 :     fn (OFFp 0) => q
199 :     | (OFFp i) => (case q of
200 :     (OFFp j) => OFFp(i+j)
201 :     | (SELp(j,p)) => SELp(i+j,p))
202 :     | (SELp(i,p)) => SELp(i,comb p)
203 :     in comb p
204 :     end
205 :    
206 :     fun lenp(OFFp _) = 0
207 :     | lenp(SELp(_,p)) = 1 + lenp p
208 :    
209 :     val BOGt = PTRt(VPT) (* bogus pointer type whose length is unknown *)
210 :    
211 :     local structure LT = LtyExtern
212 :     val tc_real = LT.tcc_real
213 :     val lt_real = LT.ltc_real
214 :     in
215 :    
216 :     fun tcflt tc = if LT.tc_eqv(tc, tc_real) then true else false
217 :     fun ltflt lt = if LT.lt_eqv(lt, lt_real) then true else false
218 :    
219 :     fun rtyc (f, []) = RPT 0
220 :     | rtyc (f, ts) =
221 :     let fun loop (a::r, b, len) =
222 :     if f a then loop(r, b, len+1) else loop(r, false, len+1)
223 :     | loop ([], b, len) = if b then FPT len else RPT len
224 :     in loop(ts, true, 0)
225 :     end
226 :    
227 :     fun ctyc tc =
228 :     LT.tcw_prim(tc,
229 :     fn pt => (if pt = PT.ptc_int31 then INTt
230 :     else if pt = PT.ptc_int32 then INT32t
231 :     else if pt = PT.ptc_real then FLTt
232 :     else BOGt),
233 :     fn tc =>
234 :     LT.tcw_tuple (tc, fn ts => PTRt(rtyc(tcflt, ts)),
235 :     fn tc => if LT.tcp_arrow tc then FUNt
236 :     else if LT.tcp_cont tc then CNTt
237 :     else BOGt))
238 :    
239 :     fun ctype lt =
240 :     LT.ltw_tyc(lt, fn tc => ctyc tc,
241 :     fn lt =>
242 :     LT.ltw_str(lt, fn ts => PTRt(rtyc(fn _ => false, ts)),
243 :     fn lt => if LT.ltp_fct lt then FUNt
244 :     else if LT.ltp_cont lt then CNTt
245 :     else BOGt))
246 :    
247 :     end (* local ctype *)
248 :    
249 :     end (* top-level local *)
250 :     end (* structure CPS *)
251 :    

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