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

Annotation of /sml/branches/SMLNJ/src/compiler/Semant/statenv/prim.sml

Parent Directory Parent Directory | Revision Log Revision Log


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

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