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/Semant/statenv/prim.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Semant/statenv/prim.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* prim.sml *)
3 :    
4 :     signature PRIM_ENV =
5 :     sig
6 :    
7 :     val primEnv : StaticEnv.staticEnv
8 :    
9 :     end (* signature PRIM_ENV *)
10 :    
11 :    
12 :     structure PrimEnv : PRIM_ENV =
13 :     struct
14 :    
15 :     local
16 :     structure S = Symbol
17 :     structure M = Modules
18 :     structure B = Bindings
19 :     structure SP = SymPath
20 :     structure IP = InvPath
21 :     structure SE = StaticEnv
22 :     structure EE = EntityEnv
23 :    
24 :     structure BT = BasicTypes
25 :     structure T = Types
26 :     structure TU = TypesUtil
27 :     structure MU = ModuleUtil
28 :     structure P = PrimOp
29 :    
30 :     structure ST = Stamps
31 :     structure V = VarCon
32 :    
33 :     structure A = Access
34 :     structure II = InlInfo
35 :    
36 :     in
37 :    
38 :     fun mkTycElement (name: string, tyc) =
39 :     (S.tycSymbol name, M.TYCspec{entVar=ST.special name, spec=tyc, scope=0})
40 :    
41 :     (*
42 :     * Note: this function only applies to constructors but not exceptions;
43 :     * exceptions will have a non-trivial slot number
44 :     *)
45 :     fun mkConElement (name, d) =
46 :     (S.varSymbol name, M.CONspec{spec=d, slot=NONE})
47 :    
48 :     (* primTypes structure *)
49 :     val primTypes =
50 :     let val primTycs =
51 :     [("bool", BT.boolTycon),
52 :     ("list", BT.listTycon),
53 :     ("ref", BT.refTycon),
54 :     ("unit", BT.unitTycon),
55 :     ("int", BT.intTycon),
56 :     ("int32", BT.int32Tycon),
57 :     ("real", BT.realTycon),
58 :     ("word", BT.wordTycon),
59 :     ("word8", BT.word8Tycon),
60 :     ("word32", BT.word32Tycon),
61 :     ("cont", BT.contTycon),
62 :     ("control_cont", BT.ccontTycon),
63 :     ("array", BT.arrayTycon),
64 :     ("vector", BT.vectorTycon),
65 :     ("object", BT.objectTycon),
66 :     ("c_function", BT.c_functionTycon),
67 :     ("word8array", BT.word8arrayTycon),
68 :     ("real64array", BT.real64arrayTycon),
69 :     ("spin_lock", BT.spin_lockTycon),
70 :     ("string", BT.stringTycon),
71 :     ("char", BT.charTycon),
72 :     ("exn", BT.exnTycon),
73 :     ("frag", BT.fragTycon),
74 :     ("susp", BT.suspTycon)]
75 :    
76 :     val primCons =
77 :     [("true", BT.trueDcon),
78 :     ("false", BT.falseDcon),
79 :     ("::", BT.consDcon),
80 :     ("nil", BT.nilDcon),
81 :     ("ref", BT.refDcon),
82 :     ("QUOTE", BT.QUOTEDcon),
83 :     ("ANTIQUOTE", BT.ANTIQUOTEDcon),
84 :     ("$", BT.dollarDcon)]
85 :    
86 :     val tycElements = map mkTycElement primTycs
87 :     val conElements = map mkConElement primCons
88 :    
89 :    
90 :     val allElements = tycElements@conElements
91 :     val allSymbols = map #1 allElements
92 :    
93 :     val entities = foldr (fn ((_,M.TYCspec{spec,entVar,scope}),r) =>
94 :     EE.bind(entVar,M.TYCent spec,r))
95 :     EE.empty tycElements
96 :    
97 :     val entities = EntityEnv.mark(fn _ => ST.special"primEntEnv", entities)
98 :    
99 :     in M.STR{sign=M.SIG{name=SOME(S.sigSymbol "PRIMTYPES"), closed=true,
100 :     fctflag=false, stamp=ST.special "PrimTypesSig",
101 :     symbols=allSymbols,elements=allElements,
102 :     typsharing=nil,strsharing=nil,
103 :     boundeps=ref (SOME []), lambdaty=ref(NONE)},
104 :     rlzn={stamp=ST.special "PrimTypesStr",
105 :     entities=entities,
106 :     lambdaty=ref NONE,
107 :     rpath=IP.IPATH[S.strSymbol "primTypes"]},
108 :    
109 :     access=A.nullAcc, info=II.mkStrInfo []}
110 :    
111 :     end (* primTypes *)
112 :    
113 :    
114 :     (**************************************************************************
115 :     * BUILDING A COMPLETE LIST OF PRIMOPS *
116 :     **************************************************************************)
117 :    
118 :     local
119 :    
120 :     fun bits size oper = P.ARITH{oper=oper, overflow=false, kind=P.INT size}
121 :     val bits31 = bits 31
122 :     val bits32 = bits 32
123 :    
124 :     fun int size oper = P.ARITH{oper=oper, overflow=true, kind=P.INT size}
125 :     val int31 = int 31
126 :     val int32 = int 32
127 :    
128 :     fun word size oper = P.ARITH{oper=oper, overflow=false, kind=P.UINT size}
129 :     val word32 = word 32
130 :     val word31 = word 31
131 :     val word8 = word 8
132 :    
133 :     fun float size oper = P.ARITH{oper=oper, overflow=true, kind=P.FLOAT size}
134 :     val float64 = float 64
135 :    
136 :     fun purefloat size oper = P.ARITH{oper=oper,overflow=false,kind=P.FLOAT size}
137 :     val purefloat64 = purefloat 64
138 :    
139 :     fun cmp kind oper = P.CMP{oper=oper, kind=kind}
140 :     val int31cmp = cmp (P.INT 31)
141 :     val int32cmp = cmp (P.INT 32)
142 :    
143 :     val word32cmp = cmp (P.UINT 32)
144 :     val word31cmp = cmp (P.UINT 31)
145 :     val word8cmp = cmp (P.UINT 8)
146 :    
147 :     val float64cmp = cmp (P.FLOAT 64)
148 :    
149 :     val v1 = T.IBOUND 0
150 :     val v2 = T.IBOUND 1
151 :     val v3 = T.IBOUND 2
152 :    
153 :     fun pa(t1,t2) = BT.tupleTy [t1,t2]
154 :     fun tp(t1,t2,t3) = BT.tupleTy [t1,t2,t3]
155 :     fun ar(t1,t2) = BT.--> (t1, t2)
156 :    
157 :     fun ap(tc,l) = T.CONty(tc, l)
158 :     fun cnt t = T.CONty(BT.contTycon,[t])
159 :     fun ccnt t = T.CONty(BT.ccontTycon,[t])
160 :     fun rf t = T.CONty(BT.refTycon,[t])
161 :     fun ay t = T.CONty(BT.arrayTycon,[t])
162 :     fun vct t = T.CONty(BT.vectorTycon,[t])
163 :    
164 :     val bo = BT.boolTy
165 :     val i = BT.intTy
166 :     val u = BT.unitTy
167 :    
168 :     fun p0 t = SOME t
169 :     fun p1 t = SOME(T.POLYty {sign=[false], tyfun=T.TYFUN {arity=1, body=t}})
170 :     fun ep1 t = SOME(T.POLYty {sign=[true], tyfun=T.TYFUN {arity=1, body=t}})
171 :     fun p2 t = SOME(T.POLYty {sign=[false,false],
172 :     tyfun=T.TYFUN {arity=2, body=t}})
173 :     fun p3 t = SOME(T.POLYty {sign=[false,false,false],
174 :     tyfun=T.TYFUN {arity=3, body=t}})
175 :    
176 :     fun sub kind = P.NUMSUBSCRIPT{kind=kind, checked=false, immutable=false}
177 :     fun chkSub kind = P.NUMSUBSCRIPT{kind=kind, checked=true, immutable=false}
178 :    
179 :     fun subv kind = P.NUMSUBSCRIPT{kind=kind, checked=false, immutable=true}
180 :     fun chkSubv kind = P.NUMSUBSCRIPT{kind=kind, checked=true, immutable=true}
181 :    
182 :     fun update kind = P.NUMUPDATE {kind=kind, checked=false}
183 :     fun chkUpdate kind = P.NUMUPDATE {kind=kind, checked=true}
184 :    
185 :     val numSubTy = p2(ar(pa(v1,i),v2))
186 :     val numUpdTy = p2(ar(tp(v1,i,v2),u))
187 :    
188 :     in
189 :    
190 :     val allPrimops =
191 :     [("callcc", P.CALLCC, p1(ar(ar(cnt(v1),v1),v1))),
192 :     ("throw", P.THROW, p2(ar(cnt(v1),ar(v1,v2)))),
193 :     ("capture", P.CAPTURE, p1(ar(ar(ccnt(v1),v1),v1))),
194 :     ("isolate", P.ISOLATE, p1(ar(ar(v1,u),cnt(v1)))),
195 :     ("cthrow", P.THROW, p2(ar(ccnt(v1),ar(v1,v2)))),
196 :     ("!", P.DEREF, p1(ar(rf(v1),v1))),
197 :     (":=", P.ASSIGN, p1(ar(pa(rf(v1),v1),u))),
198 :     ("makeref", P.MAKEREF, p1(ar(v1,rf(v1)))),
199 :     ("boxed", P.BOXED, p1(ar(v1,bo))),
200 :     ("unboxed", P.UNBOXED, p1(ar(v1,bo))),
201 :     ("cast", P.CAST, p2(ar(v1,v2))),
202 :     ("=", P.POLYEQL, ep1(ar(pa(v1,v1),bo))),
203 :     ("<>", P.POLYNEQ, ep1(ar(pa(v1,v1),bo))),
204 :     ("ptreql", P.PTREQL, p1(ar(pa(v1,v1),bo))),
205 :     ("ptrneq", P.PTRNEQ, p1(ar(pa(v1,v1),bo))),
206 :     ("getvar", P.GETVAR, p1(ar(u,v1))),
207 :     ("setvar", P.SETVAR, p1(ar(v1,u))),
208 :     ("setpseudo", P.SETPSEUDO, p1(ar(pa(v1,i),u))),
209 :     ("getpseudo", P.GETPSEUDO, p1(ar(i,v1))),
210 :     ("mkspecial", P.MKSPECIAL, p2(ar(pa(i,v1),v2))),
211 :     ("getspecial", P.GETSPECIAL, p1(ar(v1,i))),
212 :     ("setspecial", P.SETSPECIAL, p1(ar(pa(v1,i),u))),
213 :     ("gethdlr", P.GETHDLR, p1(ar(u,cnt(v1)))),
214 :     ("sethdlr", P.SETHDLR, p1(ar(cnt(v1),u))),
215 :     ("gettag", P.GETTAG, p1(ar(v1,i))),
216 :     ("setmark", P.SETMARK, p1(ar(v1,u))),
217 :     ("dispose", P.DISPOSE, p1(ar(v1,u))),
218 :     ("compose", P.INLCOMPOSE, p3(ar(pa(ar(v2,v3),ar(v1,v2)),ar(v1,v3)))),
219 :     ("before", P.INLBEFORE, p2(ar(pa(v1,v2),v1))),
220 :    
221 :    
222 :     ("length", P.LENGTH, p1(ar(v1,i))),
223 :     ("objlength", P.OBJLENGTH, p1(ar(v1,i))),
224 :    
225 :     (*
226 :     * I believe the following five primops should not be exported into
227 :     * the InLine structure. (ZHONG)
228 :     *)
229 :     ("boxedupdate", P.BOXEDUPDATE, NONE),
230 :     ("unboxedupdate", P.UNBOXEDUPDATE, NONE),
231 :     ("getrunvec", P.GETRUNVEC, NONE),
232 :     ("uselvar", P.USELVAR, NONE),
233 :     ("deflvar", P.DEFLVAR, NONE),
234 :    
235 :     ("inlnot", P.INLNOT, NONE),
236 :     ("floor", P.ROUND{floor=true,
237 :     fromkind=P.FLOAT 64,
238 :     tokind=P.INT 31}, NONE),
239 :     ("round", P.ROUND{floor=false,
240 :     fromkind=P.FLOAT 64,
241 :     tokind=P.INT 31}, NONE),
242 :     ("real", P.REAL{fromkind=P.INT 31,
243 :     tokind=P.FLOAT 64}, NONE),
244 :    
245 :     ("ordof", P.NUMSUBSCRIPT{kind=P.INT 8,
246 :     checked=false,
247 :     immutable=true}, numSubTy),
248 :     ("store", P.NUMUPDATE{kind=P.INT 8,
249 :     checked=false}, numUpdTy),
250 :     ("inlbyteof", P.NUMSUBSCRIPT{kind=P.INT 8,
251 :     checked=true,
252 :     immutable=false}, numSubTy),
253 :     ("inlstore", P.NUMUPDATE{kind=P.INT 8,
254 :     checked=true}, numUpdTy),
255 :     ("inlordof", P.NUMSUBSCRIPT{kind=P.INT 8,
256 :     checked=true,
257 :     immutable=true}, numSubTy),
258 :    
259 :     (*** polymorphic array and vector ***)
260 :     ("mkarray", P.INLMKARRAY, p1(ar(pa(i,v1),ay(v1)))),
261 :     ("arrSub", P.SUBSCRIPT, p1(ar(pa(ay(v1),i),v1))),
262 :     ("arrChkSub", P.INLSUBSCRIPT, p1(ar(pa(ay(v1),i),v1))),
263 :     ("vecSub", P.SUBSCRIPTV, p1(ar(pa(vct(v1),i),v1))),
264 :     ("vecChkSub", P.INLSUBSCRIPTV, p1(ar(pa(vct(v1),i),v1))),
265 :     ("arrUpdate", P.UPDATE, p1(ar(tp(ay(v1),i,v1),u))),
266 :     ("arrChkUpdate", P.INLUPDATE, p1(ar(tp(ay(v1),i,v1),u))),
267 :    
268 :     (* conversion primops *)
269 :     ("test_32_31", P.TEST(32,31), NONE),
270 :     ("testu_31_31", P.TESTU(31,31), NONE),
271 :     ("testu_32_31", P.TESTU(32,31), NONE),
272 :     ("testu_32_32", P.TESTU(32,32), NONE),
273 :     ("copy_32_32", P.COPY(32,32), NONE),
274 :     ("copy_31_31", P.COPY(31,31), NONE),
275 :     ("copy_31_32", P.COPY(31,32), NONE),
276 :     ("copy_8_32", P.COPY(8,32), NONE),
277 :     ("copy_8_31", P.COPY(8,31), NONE),
278 :     ("extend_31_32", P.EXTEND(31,32), NONE),
279 :     ("extend_8_31", P.EXTEND(8,31), NONE),
280 :     ("extend_8_32", P.EXTEND(8,32), NONE),
281 :     ("trunc_32_31", P.TRUNC(32,31), NONE),
282 :     ("trunc_31_8", P.TRUNC(31,8), NONE),
283 :     ("trunc_32_8", P.TRUNC(32,8), NONE),
284 :    
285 :     (*** integer 31 primops ***)
286 :     ("i31mul", int31 (P.* ), NONE),
287 :     ("i31quot", int31 (P./), NONE),
288 :     ("i31add", int31 (P.+), NONE),
289 :     ("i31sub", int31 (P.-), NONE),
290 :     ("i31orb", bits31 P.ORB, NONE),
291 :     ("i31andb", bits31 P.ANDB, NONE),
292 :     ("i31xorb", bits31 P.XORB, NONE),
293 :     ("i31notb", bits31 P.NOTB, NONE),
294 :     ("i31neg", int31 P.~, NONE),
295 :     ("i31lshift", bits31 P.LSHIFT, NONE),
296 :     ("i31rshift", bits31 P.RSHIFT, NONE),
297 :     ("i31lt", int31cmp (P.<), NONE),
298 :     ("i31le", int31cmp (P.<=), NONE),
299 :     ("i31gt", int31cmp (P.>), NONE),
300 :     ("i31ge", int31cmp (P.>=), NONE),
301 :     ("i31ltu", word31cmp P.LTU, NONE),
302 :     ("i31geu", word31cmp P.GEU, NONE),
303 :     ("i31mod", P.INLMOD, NONE),
304 :     ("i31div", P.INLDIV, NONE),
305 :     ("i31rem", P.INLREM, NONE),
306 :     ("i31max", P.INLMAX, NONE),
307 :     ("i31min", P.INLMIN, NONE),
308 :     ("i31abs", P.INLABS, NONE),
309 :     ("i31eq", int31cmp P.EQL, NONE),
310 :     ("i31ne", int31cmp P.NEQ, NONE),
311 :    
312 :     (*** integer 32 primops ***)
313 :     ("i32mul", int32 (P.* ), NONE),
314 :     ("i32quot", int32 (P./), NONE),
315 :     ("i32add", int32 (P.+), NONE),
316 :     ("i32sub", int32 (P.-), NONE),
317 :     ("i32orb", bits32 P.ORB, NONE),
318 :     ("i32andb", bits32 P.ANDB, NONE),
319 :     ("i32xorb", bits32 P.XORB, NONE),
320 :     ("i32lshift", bits32 P.LSHIFT, NONE),
321 :     ("i32rshift", bits32 P.RSHIFT, NONE),
322 :     ("i32neg", int32 P.~, NONE),
323 :     ("i32lt", int32cmp (P.<), NONE),
324 :     ("i32le", int32cmp (P.<=), NONE),
325 :     ("i32gt", int32cmp (P.>), NONE),
326 :     ("i32ge", int32cmp (P.>=), NONE),
327 :     ("i32eq", int32cmp (P.EQL), NONE),
328 :     ("i32ne", int32cmp (P.NEQ), NONE),
329 :    
330 :     (*
331 :     * WARNING: the lambda types in translate.sml are all wrong for
332 :     * this. The inlprimops for these must be parameterized over the
333 :     * integer kind.
334 :     *
335 :     *
336 :     * ("i32mod", P.INLMOD, NONE),
337 :     * ("i32div", P.INLDIV, NONE),
338 :     * ("i32rem", P.INLREM, NONE),
339 :     * ("i32max", P.INLMAX, NONE),
340 :     * ("i32min", P.INLMIN, NONE),
341 :     * ("i32abs", P.INLABS, NONE),
342 :     *
343 :     *)
344 :    
345 :     (*** float 64 primops ***)
346 :     ("f64add", float64 (P.+), NONE),
347 :     ("f64sub", float64 (P.-), NONE),
348 :     ("f64div", float64 (P./), NONE),
349 :     ("f64mul", float64 (P.* ), NONE),
350 :     ("f64neg", purefloat64 P.~, NONE),
351 :     ("f64ge", float64cmp (P.>=), NONE),
352 :     ("f64gt", float64cmp (P.>), NONE),
353 :     ("f64le", float64cmp (P.<=), NONE),
354 :     ("f64lt", float64cmp (P.<), NONE),
355 :     ("f64eq", float64cmp P.EQL, NONE),
356 :     ("f64ne", float64cmp P.NEQ, NONE),
357 :     ("f64abs", purefloat64 P.ABS, NONE),
358 :    
359 :     (*** float64 array ***)
360 :     ("f64Sub", sub (P.FLOAT 64), numSubTy),
361 :     ("f64chkSub", chkSub (P.FLOAT 64), numSubTy),
362 :     ("f64Update", update (P.FLOAT 64), numUpdTy),
363 :     ("f64chkUpdate", chkUpdate (P.FLOAT 64), numUpdTy),
364 :    
365 :     (*** word8 primops ***)
366 :     (*
367 :     * In the long run, we plan to represent WRAPPED word8 tagged, and
368 :     * UNWRAPPED untagged. But right now, we represent both of them
369 :     * tagged, with 23 high-order zero bits and 1 low-order 1 bit.
370 :     * In this representation, we can use the comparison and (some of
371 :     * the) bitwise operators of word31; but we cannot use the shift
372 :     * and arithmetic operators.
373 :     *
374 :     * WARNING: THIS IS A TEMPORARY HACKJOB until all the word8 primops
375 :     * are correctly implemented.
376 :     *
377 :     * ("w8mul", word8 (P.* ), NONE),
378 :     * ("w8div", word8 (P./), NONE),
379 :     * ("w8add", word8 (P.+), NONE),
380 :     * ("w8sub", word8 (P.-), NONE),
381 :     *
382 :     * ("w8notb", word31 P.NOTB, NONE),
383 :     * ("w8rshift", word8 P.RSHIFT, NONE),
384 :     * ("w8rshiftl", word8 P.RSHIFTL, NONE),
385 :     * ("w8lshift", word8 P.LSHIFT, NONE),
386 :     *
387 :     * ("w8toint", P.ROUND{floor=true,
388 :     * fromkind=P.UINT 8,
389 :     * tokind=P.INT 31}, NONE),
390 :     * ("w8fromint", P.REAL{fromkind=P.INT 31,
391 :     * tokind=P.UINT 8}, NONE),
392 :     *)
393 :    
394 :     ("w8orb", word31 P.ORB, NONE),
395 :     ("w8xorb", word31 P.XORB, NONE),
396 :     ("w8andb", word31 P.ANDB, NONE),
397 :    
398 :     ("w8gt", word8cmp P.>, NONE),
399 :     ("w8ge", word8cmp P.>=, NONE),
400 :     ("w8lt", word8cmp P.<, NONE),
401 :     ("w8le", word8cmp P.<=, NONE),
402 :     ("w8eq", word8cmp P.EQL, NONE),
403 :     ("w8ne", word8cmp P.NEQ, NONE),
404 :    
405 :     (*** word8 array and vector ***)
406 :     ("w8Sub", sub (P.UINT 8), numSubTy),
407 :     ("w8chkSub", chkSub (P.UINT 8), numSubTy),
408 :     ("w8subv", subv (P.UINT 8), numSubTy),
409 :     ("w8chkSubv", chkSubv (P.UINT 8), numSubTy),
410 :     ("w8update", update (P.UINT 8), numUpdTy),
411 :     ("w8chkUpdate", chkUpdate (P.UINT 8), numUpdTy),
412 :    
413 :     (* word31 primops *)
414 :     ("w31mul", word31 (P.* ), NONE),
415 :     ("w31div", word31 (P./), NONE),
416 :     ("w31add", word31 (P.+), NONE),
417 :     ("w31sub", word31 (P.-), NONE),
418 :     ("w31orb", word31 P.ORB, NONE),
419 :     ("w31xorb", word31 P.XORB, NONE),
420 :     ("w31andb", word31 P.ANDB, NONE),
421 :     ("w31notb", word31 P.NOTB, NONE),
422 :     ("w31rshift", word31 P.RSHIFT, NONE),
423 :     ("w31rshiftl", word31 P.RSHIFTL, NONE),
424 :     ("w31lshift", word31 P.LSHIFT, NONE),
425 :     ("w31gt", word31cmp (P.>), NONE),
426 :     ("w31ge", word31cmp (P.>=), NONE),
427 :     ("w31lt", word31cmp (P.<), NONE),
428 :     ("w31le", word31cmp (P.<=), NONE),
429 :     ("w31eq", word31cmp P.EQL, NONE),
430 :     ("w31ne", word31cmp P.NEQ, NONE),
431 :     ("w31ChkRshift", P.INLRSHIFT(P.UINT 31), NONE),
432 :     ("w31ChkRshiftl",P.INLRSHIFTL(P.UINT 31), NONE),
433 :     ("w31ChkLshift", P.INLLSHIFT(P.UINT 31), NONE),
434 :    
435 :     (*** word32 primops ***)
436 :     ("w32mul", word32 (P.* ), NONE),
437 :     ("w32div", word32 (P./), NONE),
438 :     ("w32add", word32 (P.+), NONE),
439 :     ("w32sub", word32 (P.-), NONE),
440 :     ("w32orb", word32 P.ORB, NONE),
441 :     ("w32xorb", word32 P.XORB, NONE),
442 :     ("w32andb", word32 P.ANDB, NONE),
443 :     ("w32notb", word32 P.NOTB, NONE),
444 :     ("w32rshift", word32 P.RSHIFT, NONE),
445 :     ("w32rshiftl", word32 P.RSHIFTL, NONE),
446 :     ("w32lshift", word32 P.LSHIFT, NONE),
447 :     ("w32gt", word32cmp (P.>), NONE),
448 :     ("w32ge", word32cmp (P.>=), NONE),
449 :     ("w32lt", word32cmp (P.<), NONE),
450 :     ("w32le", word32cmp (P.<=), NONE),
451 :     ("w32eq", word32cmp P.EQL, NONE),
452 :     ("w32ne", word32cmp P.NEQ, NONE),
453 :     ("w32ChkRshift", P.INLRSHIFT(P.UINT 32), NONE),
454 :     ("w32ChkRshiftl",P.INLRSHIFTL(P.UINT 32),NONE),
455 :     ("w32ChkLshift", P.INLLSHIFT(P.UINT 32), NONE)
456 :     ]
457 :    
458 :     end (* local *)
459 :    
460 :     (* uList structure *)
461 :     val uList =
462 :     let val ev = ST.special "uListVar"
463 :     val allElements =
464 :     [(S.tycSymbol "list", M.TYCspec{spec=BT.ulistTycon,entVar=ev,scope=0}),
465 :     mkConElement("nil", BT.unilDcon),
466 :     mkConElement("::", BT.uconsDcon)]
467 :     val allSymbols = map #1 allElements
468 :    
469 :     in M.STR{sign=M.SIG{name=NONE, closed=true,
470 :     fctflag=false, stamp=ST.special "uListSig",
471 :     symbols=allSymbols, elements=allElements,
472 :     typsharing=nil, strsharing=nil,
473 :     boundeps=ref (SOME []), lambdaty=ref NONE},
474 :    
475 :     rlzn={stamp=ST.special "uListStr",
476 :     entities=EE.bind(ev,M.TYCent BT.ulistTycon,EE.empty),
477 :     lambdaty=ref(NONE),
478 :     rpath=IP.IPATH[S.strSymbol "uList"]},
479 :    
480 :     access=A.nullAcc, info=II.mkStrInfo[]}
481 :     end
482 :    
483 :     (* inLine structure *)
484 :     val inLine =
485 :     let val bottom = T.POLYty{sign=[false],
486 :     tyfun=T.TYFUN{arity=1,body=T.IBOUND 0}}
487 :     (*
488 :     * Using bottom here is a major gross hack. In the future, the actual
489 :     * type should be given in the P.allPrimops list. Right now, only
490 :     * polymorphic primOps are given the type --- to order to support
491 :     * the type-based analysis correctly. (ZHONG)
492 :     *)
493 :    
494 :     fun mkVarElement((name, p, tyOp),(symbols,elements,dacc,offset)) =
495 :     let val s = S.varSymbol name
496 :     val t = case tyOp of NONE => bottom
497 :     | SOME x => x
498 :     val sp = M.VALspec{spec=t, slot=offset}
499 :     val d = II.mkPrimInfo(p, tyOp)
500 :     in (s::symbols, (s,sp)::elements, d::dacc, offset+1)
501 :     end
502 :    
503 :     val (allSymbols, allElements, infList, _) =
504 :     foldl mkVarElement ([],[],[],0) allPrimops
505 :    
506 :     val (allSymbols, allElements, infList) =
507 :     (rev allSymbols, rev allElements, rev infList)
508 :    
509 :     in M.STR{sign=M.SIG{name=NONE, closed=true,
510 :     fctflag=false, stamp=ST.special "inLineSig",
511 :     symbols=allSymbols, elements=allElements,
512 :     typsharing=nil, strsharing=nil,
513 :     boundeps=ref (SOME []), lambdaty=ref NONE},
514 :    
515 :     rlzn={stamp=ST.special "inLineStr", entities=EE.empty,
516 :     lambdaty=ref(NONE),
517 :     rpath=IP.IPATH[S.strSymbol "inLine"]},
518 :    
519 :     access=A.nullAcc, info=(II.mkStrInfo infList)}
520 :     end
521 :    
522 :     (* priming structures: PrimTypes and InLine *)
523 :     val nameofPT = S.strSymbol "PrimTypes"
524 :     val nameofUL = S.strSymbol "UnrolledList"
525 :     val nameofIL = S.strSymbol "InLine"
526 :    
527 :     val primEnv =
528 :     SE.bind(nameofIL,B.STRbind inLine,
529 :     SE.bind(nameofUL,B.STRbind uList,
530 :     SE.bind(nameofPT,B.STRbind primTypes,
531 :     MU.openStructure(SE.empty,primTypes))))
532 :    
533 :    
534 :     end (* local *)
535 :     end (* structure PrimEnv *)
536 :    
537 :    

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