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

Annotation of /sml/branches/primop-branch-3/compiler/Semant/statenv/prim.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2408 - (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 :    
27 :     structure ST = Stamps
28 :     structure V = VarCon
29 :    
30 :     structure A = Access
31 :    
32 :     in
33 :    
34 :     fun mkTycElement (name: string, tyc) =
35 :     (S.tycSymbol name, M.TYCspec{entVar=ST.special name, spec=tyc, repl=false,
36 :     scope=0})
37 :    
38 :     (*
39 :     * Note: this function only applies to constructors but not exceptions;
40 :     * exceptions will have a non-trivial slot number
41 :     *)
42 :     fun mkConElement (name, d) =
43 :     (S.varSymbol name, M.CONspec{spec=d, slot=NONE})
44 :    
45 : blume 772 (* Below there is a bunch of very long list literals which would create
46 :     * huge register pressure on the compiler. We construct them backwards
47 :     * using an alternative "cons" that takes its two arguments in opposite
48 :     * order. This effectively puts the lists' ends to the left and alleviates
49 :     * this effect. (Stupid ML trick No. 21b) (Blume, 1/2001) *)
50 :     infix :-: (* inverse :: *)
51 :     fun l :-: e = e :: l
52 :    
53 : monnier 249 (* primTypes structure *)
54 :     val primTypes =
55 :     let val primTycs =
56 : blume 772 [] :-:
57 :     ("bool", BT.boolTycon) :-:
58 :     ("list", BT.listTycon) :-:
59 :     ("ref", BT.refTycon) :-:
60 :     ("unit", BT.unitTycon) :-:
61 :     ("int", BT.intTycon) :-:
62 :     ("int32", BT.int32Tycon) :-:
63 : mblume 1682 ("int64", BT.int64Tycon) :-:
64 : mblume 1347 ("intinf", BT.intinfTycon) :-:
65 : blume 772 ("real", BT.realTycon) :-:
66 :     ("word", BT.wordTycon) :-:
67 :     ("word8", BT.word8Tycon) :-:
68 :     ("word32", BT.word32Tycon) :-:
69 : mblume 1682 ("word64", BT.word64Tycon) :-:
70 : blume 772 ("cont", BT.contTycon) :-:
71 :     ("control_cont", BT.ccontTycon) :-:
72 :     ("array", BT.arrayTycon) :-:
73 :     ("vector", BT.vectorTycon) :-:
74 :     ("object", BT.objectTycon) :-:
75 :     ("c_function", BT.c_functionTycon) :-:
76 :     ("word8array", BT.word8arrayTycon) :-:
77 :     ("real64array", BT.real64arrayTycon) :-:
78 :     ("spin_lock", BT.spin_lockTycon) :-:
79 :     ("string", BT.stringTycon) :-:
80 :     ("char", BT.charTycon) :-:
81 :     ("exn", BT.exnTycon) :-:
82 :     ("frag", BT.fragTycon) :-:
83 :     ("susp", BT.suspTycon)
84 : monnier 249
85 :     val primCons =
86 : blume 772 [] :-:
87 :     ("true", BT.trueDcon) :-:
88 :     ("false", BT.falseDcon) :-:
89 :     ("::", BT.consDcon) :-:
90 :     ("nil", BT.nilDcon) :-:
91 :     ("ref", BT.refDcon) :-:
92 :     ("QUOTE", BT.QUOTEDcon) :-:
93 :     ("ANTIQUOTE", BT.ANTIQUOTEDcon) :-:
94 :     ("$", BT.dollarDcon)
95 : monnier 249
96 :     val tycElements = map mkTycElement primTycs
97 :     val conElements = map mkConElement primCons
98 :    
99 :     val allElements = tycElements@conElements
100 :     val allSymbols = map #1 allElements
101 :    
102 : blume 587 val entities = let
103 :     fun f ((_,M.TYCspec{spec,entVar,repl,scope}),r) =
104 :     EE.bind(entVar,M.TYCent spec,r)
105 :     | f _ = ErrorMsg.impossible "primTypes:entities"
106 :     in
107 :     foldr f EE.empty tycElements
108 :     end
109 : monnier 249
110 :     val entities = EntityEnv.mark(fn _ => ST.special"primEntEnv", entities)
111 :    
112 : blume 902 val sigrec =
113 :     {stamp=ST.special "PrimTypesSig",
114 :     name=SOME(S.sigSymbol "PRIMTYPES"), closed=true,
115 :     fctflag=false,
116 :     symbols=allSymbols,elements=allElements,
117 :     typsharing=nil,strsharing=nil,
118 :     properties = PropList.newHolder (),
119 :     (* boundeps=ref (SOME []), *)
120 :     (* lambdaty=ref(NONE), *)
121 :     stub = NONE}
122 :     val _ = ModulePropLists.setSigBoundeps (sigrec, SOME [])
123 :     val strrec =
124 :     {sign=M.SIG sigrec,
125 :     rlzn={stamp=ST.special "PrimTypesStr",
126 :     stub=NONE,
127 :     entities=entities,
128 :     properties = PropList.newHolder (),
129 :     (* lambdaty=ref NONE, *)
130 :     rpath=IP.IPATH[S.strSymbol "primTypes"]},
131 : blume 2222 access=A.nullAcc, prim= []}
132 : blume 902 in M.STR strrec
133 : monnier 249
134 :     end (* primTypes *)
135 :    
136 :    
137 :     (**************************************************************************
138 :     * BUILDING A COMPLETE LIST OF PRIMOPS *
139 :     **************************************************************************)
140 :    
141 : blume 2222 (* We generate unique numbers for each primop, and bind them as components
142 :     of a structure InLine, with the generic type all = (All 'a).'a. The primop
143 :     intrinsic types will be specified in a separate table used in the translate
144 :     phase (and FLINT?).
145 :     *)
146 : monnier 249
147 : blume 2222 (*
148 : monnier 249 val v1 = T.IBOUND 0
149 : blume 772 fun p1 t = T.POLYty {sign=[false], tyfun=T.TYFUN {arity=1, body=t}}
150 : blume 2222 *)
151 :     (* the generic type (All 'a).'a *)
152 :     val all = T.POLYty {sign=[false], tyfun=T.TYFUN {arity=1, body=T.IBOUND 0}}
153 : monnier 249
154 :     val allPrimops =
155 : blume 2222 ["callcc",
156 :     "throw",
157 :     "capture",
158 :     "isolate",
159 :     "cthrow",
160 :     "!",
161 :     ":=",
162 :     "makeref",
163 :     "boxed",
164 :     "unboxed",
165 :     "cast",
166 :     "=",
167 :     "<>",
168 :     "ptreql",
169 :     "ptrneq",
170 :     "getvar",
171 :     "setvar",
172 :     "setpseudo",
173 :     "getpseudo",
174 :     "mkspecial",
175 :     "getspecial",
176 :     "setspecial",
177 :     "gethdlr",
178 :     "sethdlr",
179 :     "gettag",
180 :     "setmark",
181 :     "dispose",
182 :     "compose",
183 :     "before",
184 :     "ignore",
185 :     "identity",
186 :     "length",
187 :     "objlength",
188 :     "unboxedupdate",
189 :     "inlnot",
190 :     "floor",
191 :     "round",
192 :     "real",
193 :     "real32",
194 :     "ordof",
195 :     "store",
196 :     "inlbyteof",
197 :     "inlstore",
198 :     "inlordof",
199 :     "mkarray",
200 :     "arrSub",
201 :     "arrChkSub",
202 :     "vecSub",
203 :     "vecChkSub",
204 :     "arrUpdate",
205 :     "arrChkUpdate",
206 :     "newArray0",
207 :     "getSeqData",
208 :     "recordSub",
209 :     "raw64Sub",
210 :     "test_32_31_w",
211 :     "test_32_31_i",
212 :     "testu_31_31",
213 :     "testu_32_31",
214 :     "testu_32_32",
215 :     "copy_32_32_ii",
216 :     "copy_32_32_wi",
217 :     "copy_32_32_iw",
218 :     "copy_32_32_ww",
219 :     "copy_31_31_ii",
220 :     "copy_31_31_wi",
221 :     "copy_31_31_iw",
222 :     "copy_31_32_i",
223 :     "copy_31_32_w",
224 :     "copy_8_32_i",
225 :     "copy_8_32_w",
226 :     "copy_8_31",
227 :     "extend_31_32_ii",
228 :     "extend_31_32_iw",
229 :     "extend_31_32_wi",
230 :     "extend_31_32_ww",
231 :     "extend_8_31",
232 :     "extend_8_32_i",
233 :     "extend_8_32_w",
234 :     "trunc_32_31_i",
235 :     "trunc_32_31_w",
236 :     "trunc_31_8",
237 :     "trunc_32_8_i",
238 :     "trunc_32_8_w",
239 :     "test_inf_31",
240 :     "test_inf_32",
241 :     "test_inf_64",
242 :     "copy_8_inf",
243 :     "copy_8_inf_w",
244 :     "copy_31_inf_w",
245 :     "copy_32_inf_w",
246 :     "copy_64_inf_w",
247 :     "copy_31_inf_i",
248 :     "copy_32_inf_i",
249 :     "copy_64_inf_i",
250 :     "extend_8_inf",
251 :     "extend_8_inf_w",
252 :     "extend_31_inf_w",
253 :     "extend_32_inf_w",
254 :     "extend_64_inf_w",
255 :     "extend_31_inf_i",
256 :     "extend_32_inf_i",
257 :     "extend_64_inf_i",
258 :     "trunc_inf_8",
259 :     "trunc_inf_31",
260 :     "trunc_inf_32",
261 :     "trunc_inf_64",
262 :     "w64p",
263 :     "p64w",
264 :     "i64p",
265 :     "p64i",
266 :     "i31add",
267 :     "i31add_8",
268 :     "i31sub",
269 :     "i31sub_8",
270 :     "i31mul",
271 :     "i31mul_8",
272 :     "i31div",
273 :     "i31div_8",
274 :     "i31mod",
275 :     "i31mod_8",
276 :     "i31quot",
277 :     "i31rem",
278 :     "i31orb",
279 :     "i31orb_8",
280 :     "i31andb",
281 :     "i31andb_8",
282 :     "i31xorb",
283 :     "i31xorb_8",
284 :     "i31notb",
285 :     "i31notb_8",
286 :     "i31neg",
287 :     "i31neg_8",
288 :     "i31lshift",
289 :     "i31lshift_8",
290 :     "i31rshift",
291 :     "i31rshift_8",
292 :     "i31lt",
293 :     "i31lt_8",
294 :     "i31lt_c",
295 :     "i31le",
296 :     "i31le_8",
297 :     "i31le_c",
298 :     "i31gt",
299 :     "i31gt_8",
300 :     "i31gt_c",
301 :     "i31ge",
302 :     "i31ge_8",
303 :     "i31ge_c",
304 :     "i31ltu",
305 :     "i31geu",
306 :     "i31eq",
307 :     "i31ne",
308 :     "i31min",
309 :     "i31min_8",
310 :     "i31max",
311 :     "i31max_8",
312 :     "i31abs",
313 :     "i32mul",
314 :     "i32div",
315 :     "i32mod",
316 :     "i32quot",
317 :     "i32rem",
318 :     "i32add",
319 :     "i32sub",
320 :     "i32orb",
321 :     "i32andb",
322 :     "i32xorb",
323 :     "i32lshift",
324 :     "i32rshift",
325 :     "i32neg",
326 :     "i32lt",
327 :     "i32le",
328 :     "i32gt",
329 :     "i32ge",
330 :     "i32eq",
331 :     "i32ne",
332 :     "i32min",
333 :     "i32max",
334 :     "i32abs",
335 :     "f64add",
336 :     "f64sub",
337 :     "f64div",
338 :     "f64mul",
339 :     "f64neg",
340 :     "f64ge",
341 :     "f64gt",
342 :     "f64le",
343 :     "f64lt",
344 :     "f64eq",
345 :     "f64ne",
346 :     "f64abs",
347 :     "f64sin",
348 :     "f64cos",
349 :     "f64tan",
350 :     "f64sqrt",
351 :     "f64min",
352 :     "f64max",
353 :     "f64Sub",
354 :     "f64chkSub",
355 :     "f64Update",
356 :     "f64chkUpdate",
357 :     "w8orb",
358 :     "w8xorb",
359 :     "w8andb",
360 :     "w8gt",
361 :     "w8ge",
362 :     "w8lt",
363 :     "w8le",
364 :     "w8eq",
365 :     "w8ne",
366 :     "w8Sub",
367 :     "w8chkSub",
368 :     "w8subv",
369 :     "w8chkSubv",
370 :     "w8update",
371 :     "w8chkUpdate",
372 :     "w31mul",
373 :     "w31div",
374 :     "w31mod",
375 :     "w31add",
376 :     "w31sub",
377 :     "w31orb",
378 :     "w31xorb",
379 :     "w31andb",
380 :     "w31notb",
381 :     "w31neg",
382 :     "w31rshift",
383 :     "w31rshiftl",
384 :     "w31lshift",
385 :     "w31gt",
386 :     "w31ge",
387 :     "w31lt",
388 :     "w31le",
389 :     "w31eq",
390 :     "w31ne",
391 :     "w31ChkRshift",
392 :     "w31ChkRshiftl",
393 :     "w31ChkLshift",
394 :     "w31min",
395 :     "w31max",
396 :     "w31mul_8",
397 :     "w31div_8",
398 :     "w31mod_8",
399 :     "w31add_8",
400 :     "w31sub_8",
401 :     "w31orb_8",
402 :     "w31xorb_8",
403 :     "w31andb_8",
404 :     "w31notb_8",
405 :     "w31neg_8",
406 :     "w31rshift_8",
407 :     "w31rshiftl_8",
408 :     "w31lshift_8",
409 :     "w31gt_8",
410 :     "w31ge_8",
411 :     "w31lt_8",
412 :     "w31le_8",
413 :     "w31eq_8",
414 :     "w31ne_8",
415 :     "w31ChkRshift_8",
416 :     "w31ChkRshiftl_8",
417 :     "w31ChkLshift_8",
418 :     "w31min_8",
419 :     "w31max_8",
420 :     "w32mul",
421 :     "w32div",
422 :     "w32mod",
423 :     "w32add",
424 :     "w32sub",
425 :     "w32orb",
426 :     "w32xorb",
427 :     "w32andb",
428 :     "w32notb",
429 :     "w32neg",
430 :     "w32rshift",
431 :     "w32rshiftl",
432 :     "w32lshift",
433 :     "w32gt",
434 :     "w32ge",
435 :     "w32lt",
436 :     "w32le",
437 :     "w32eq",
438 :     "w32ne",
439 :     "w32ChkRshift",
440 :     "w32ChkRshiftl",
441 :     "w32ChkLshift",
442 :     "w32min",
443 :     "w32max",
444 :     "raww8l",
445 :     "rawi8l",
446 :     "raww16l",
447 :     "rawi16l",
448 :     "raww32l",
449 :     "rawi32l",
450 :     "rawf32l",
451 :     "rawf64l",
452 :     "raww8s",
453 :     "rawi8s",
454 :     "raww16s",
455 :     "rawi16s",
456 :     "raww32s",
457 :     "rawi32s",
458 :     "rawf32s",
459 :     "rawf64s",
460 :     "rawccall",
461 :     "rawrecord",
462 :     "rawrecord64",
463 :     "rawselectw8",
464 :     "rawselecti8",
465 :     "rawselectw16",
466 :     "rawselecti16",
467 :     "rawselectw32",
468 :     "rawselecti32",
469 :     "rawselectf32",
470 :     "rawselectf64",
471 :     "rawupdatew8",
472 :     "rawupdatei8",
473 :     "rawupdatew16",
474 :     "rawupdatei16",
475 :     "rawupdatew32",
476 :     "rawupdatei32",
477 :     "rawupdatef32",
478 :     "rawupdatef64"]
479 : monnier 249
480 :     (* uList structure *)
481 :     val uList =
482 :     let val ev = ST.special "uListVar"
483 :     val allElements =
484 :     [(S.tycSymbol "list", M.TYCspec{spec=BT.ulistTycon,entVar=ev,
485 :     repl=false,scope=0}),
486 :     mkConElement("nil", BT.unilDcon),
487 :     mkConElement("::", BT.uconsDcon)]
488 :     val allSymbols = map #1 allElements
489 : blume 902 val sigrec = {stamp=ST.special "uListSig",
490 : blume 587 name=NONE, closed=true,
491 :     fctflag=false,
492 :     symbols=allSymbols, elements=allElements,
493 :     typsharing=nil, strsharing=nil,
494 : blume 902 properties = PropList.newHolder (),
495 :     (* boundeps=ref (SOME []), *)
496 :     (* lambdaty=ref NONE, *)
497 :     stub = NONE}
498 :     val _ = ModulePropLists.setSigBoundeps (sigrec, SOME [])
499 :     in M.STR{sign=M.SIG sigrec,
500 : monnier 249 rlzn={stamp=ST.special "uListStr",
501 : blume 587 stub=NONE,
502 :     entities=EE.bind(ev,M.TYCent BT.ulistTycon,EE.empty),
503 : blume 902 properties = PropList.newHolder (),
504 :     (* lambdaty=ref(NONE), *)
505 : blume 587 rpath=IP.IPATH[S.strSymbol "uList"]},
506 : blume 2222 access=A.nullAcc, prim= []}
507 : monnier 249 end
508 :    
509 :     (* inLine structure *)
510 :     val inLine =
511 :     let val bottom = T.POLYty{sign=[false],
512 :     tyfun=T.TYFUN{arity=1,body=T.IBOUND 0}}
513 :    
514 : blume 2222 fun mkVarElement(name,(symbols,elements,primElems,offset)) =
515 : monnier 249 let val s = S.varSymbol name
516 : blume 2222 val ty =
517 :     (case PrimOpTypeMap.primopTypeMap name (* the intrinsic type *)
518 :     of SOME ty => ty
519 :     | NONE => ErrorMsg.impossible("PrimEnv: inLine reference to \
520 :     \ undefined prim " ^ name))
521 :     val sp = M.VALspec{spec=ty, slot=offset}
522 :     (* using universal generic type bottom for all components *)
523 :     val p = PrimOpId.PrimE(PrimOpId.Prim name) (* the primop code *)
524 :     in (s::symbols, (s,sp)::elements, p::primElems, offset+1)
525 : monnier 249 end
526 :    
527 : blume 2222 val (allSymbols, allElements, primList, _) =
528 : monnier 249 foldl mkVarElement ([],[],[],0) allPrimops
529 :    
530 : blume 2222 val (allSymbols, allElements, primList) =
531 :     (rev allSymbols, rev allElements, rev primList)
532 : monnier 249
533 : blume 902 val sigrec ={stamp=ST.special "inLineSig",
534 : blume 2222 name=NONE, closed=true,
535 :     fctflag=false,
536 :     symbols=allSymbols, elements=allElements,
537 :     typsharing=nil, strsharing=nil,
538 :     properties = PropList.newHolder (), (* dbm: ??? *)
539 :     stub = NONE}
540 :    
541 : blume 902 val _ = ModulePropLists.setSigBoundeps (sigrec, SOME [])
542 : blume 2222
543 :     in M.STR{sign = M.SIG sigrec,
544 :     rlzn = {stamp=ST.special "inLineStr",
545 :     stub=NONE,
546 :     entities=EE.empty,
547 :     properties = PropList.newHolder (), (* dbm: ??? *)
548 :     rpath=IP.IPATH[S.strSymbol "inLine"]},
549 :     access = A.nullAcc,
550 :     prim = primList}
551 : monnier 249 end
552 :    
553 :     (* priming structures: PrimTypes and InLine *)
554 :     val nameofPT = S.strSymbol "PrimTypes"
555 :     val nameofUL = S.strSymbol "UnrolledList"
556 :     val nameofIL = S.strSymbol "InLine"
557 :    
558 :     val primEnv =
559 :     SE.bind(nameofIL,B.STRbind inLine,
560 :     SE.bind(nameofUL,B.STRbind uList,
561 :     SE.bind(nameofPT,B.STRbind primTypes,
562 :     MU.openStructure(SE.empty,primTypes))))
563 :    
564 : blume 587 val primEnv = let
565 :     val { hash, pickle, ... } =
566 :     PickMod.pickleEnv (PickMod.INITIAL ModuleId.emptyTmap) primEnv
567 :     in
568 :     UnpickMod.unpickleEnv (fn _ => ModuleId.emptyTmap) (hash, pickle)
569 :     end
570 : monnier 249
571 :     end (* local *)
572 : blume 2222
573 : monnier 249 end (* structure PrimEnv *)

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