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 93 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/cps/cps.sml

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

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