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 587 - (view) (download)

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

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