Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009-2010,2014,2016-2017 Matthew Fluet. |
2 | * Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor RepType (S: REP_TYPE_STRUCTS): REP_TYPE = | |
10 | struct | |
11 | ||
12 | open S | |
13 | ||
14 | structure CFunction = CFunction | |
15 | ||
16 | structure Type = | |
17 | struct | |
18 | datatype t = T of {node: node, | |
19 | width: Bits.t} | |
20 | and node = | |
21 | Bits | |
22 | | CPointer | |
23 | | ExnStack | |
24 | | GCState | |
25 | | Label of Label.t | |
26 | | Objptr of ObjptrTycon.t vector | |
27 | | Real of RealSize.t | |
28 | | Seq of t vector | |
29 | | Word of WordSize.t | |
30 | ||
31 | local | |
32 | fun make f (T r) = f r | |
33 | in | |
34 | val node = make #node | |
35 | val width = make #width | |
36 | end | |
37 | val bytes: t -> Bytes.t = Bits.toBytes o width | |
38 | ||
39 | val rec layout: t -> Layout.t = | |
40 | fn t => | |
41 | let | |
42 | open Layout | |
43 | in | |
44 | case node t of | |
45 | Bits => str (concat ["Bits", Bits.toString (width t)]) | |
46 | | CPointer => str "CPointer" | |
47 | | ExnStack => str "ExnStack" | |
48 | | GCState => str "GCState" | |
49 | | Label l => seq [str "Label ", Label.layout l] | |
50 | | Objptr opts => | |
51 | seq [str "Objptr ", | |
52 | tuple (Vector.toListMap (opts, ObjptrTycon.layout))] | |
53 | | Real s => str (concat ["Real", RealSize.toString s]) | |
54 | | Seq ts => List.layout layout (Vector.toList ts) | |
55 | | Word s => str (concat ["Word", WordSize.toString s]) | |
56 | end | |
57 | ||
58 | val rec equals: t * t -> bool = | |
59 | fn (t, t') => | |
60 | Bits.equals (width t, width t') | |
61 | andalso | |
62 | (case (node t, node t') of | |
63 | (Bits, Bits) => true | |
64 | | (CPointer, CPointer) => true | |
65 | | (ExnStack, ExnStack) => true | |
66 | | (GCState, GCState) => true | |
67 | | (Label l, Label l') => Label.equals (l, l') | |
68 | | (Objptr opts, Objptr opts') => | |
69 | Vector.equals (opts, opts', ObjptrTycon.equals) | |
70 | | (Real s, Real s') => RealSize.equals (s, s') | |
71 | | (Seq ts, Seq ts') => Vector.equals (ts, ts', equals) | |
72 | | (Word s, Word s') => WordSize.equals (s, s') | |
73 | | _ => false) | |
74 | ||
75 | val sameWidth: t * t -> bool = | |
76 | fn (t, t') => Bits.equals (width t, width t') | |
77 | ||
78 | ||
79 | val bits: Bits.t -> t = fn width => T {node = Bits, width = width} | |
80 | ||
81 | val cpointer: unit -> t = fn () => | |
82 | T {node = CPointer, width = WordSize.bits (WordSize.cpointer ())} | |
83 | ||
84 | val exnStack: unit -> t = fn () => | |
85 | T {node = ExnStack, width = WordSize.bits (WordSize.csize ())} | |
86 | ||
87 | val gcState: unit -> t = fn () => | |
88 | T {node = GCState, width = WordSize.bits (WordSize.cpointer ())} | |
89 | ||
90 | val label: Label.t -> t = | |
91 | fn l => T {node = Label l, width = WordSize.bits (WordSize.cpointer ())} | |
92 | ||
93 | val objptr: ObjptrTycon.t -> t = | |
94 | fn opt => T {node = Objptr (Vector.new1 opt), | |
95 | width = WordSize.bits (WordSize.objptr ())} | |
96 | ||
97 | val real: RealSize.t -> t = | |
98 | fn s => T {node = Real s, width = RealSize.bits s} | |
99 | ||
100 | val word: WordSize.t -> t = | |
101 | fn s => T {node = Word s, width = WordSize.bits s} | |
102 | ||
103 | ||
104 | val bool: t = word WordSize.bool | |
105 | ||
106 | val csize: unit -> t = word o WordSize.csize | |
107 | ||
108 | val cint: unit -> t = word o WordSize.cint | |
109 | ||
110 | val compareRes = word WordSize.compareRes | |
111 | ||
112 | val objptrHeader: unit -> t = word o WordSize.objptrHeader | |
113 | ||
114 | val seqIndex: unit -> t = word o WordSize.seqIndex | |
115 | ||
116 | val shiftArg: t = word WordSize.shiftArg | |
117 | ||
118 | val stack : unit -> t = fn () => | |
119 | objptr ObjptrTycon.stack | |
120 | ||
121 | val thread : unit -> t = fn () => | |
122 | objptr ObjptrTycon.thread | |
123 | ||
124 | val word0: t = bits Bits.zero | |
125 | val word8: t = word WordSize.word8 | |
126 | val word32: t = word WordSize.word32 | |
127 | ||
128 | val wordVector: WordSize.t -> t = | |
129 | objptr o ObjptrTycon.wordVector o WordSize.bits | |
130 | ||
131 | val word8Vector: unit -> t = fn () => | |
132 | wordVector WordSize.word8 | |
133 | ||
134 | val string: unit -> t = word8Vector | |
135 | ||
136 | val unit: t = bits Bits.zero | |
137 | ||
138 | val zero: Bits.t -> t = bits | |
139 | ||
140 | ||
141 | val ofWordX: WordX.t -> t = | |
142 | fn w => word (WordX.size w) | |
143 | ||
144 | fun ofWordXVector (v: WordXVector.t): t = | |
145 | wordVector (WordXVector.elementSize v) | |
146 | ||
147 | ||
148 | val seq: t vector -> t = | |
149 | fn ts => | |
150 | if Vector.isEmpty ts | |
151 | then unit | |
152 | else | |
153 | let | |
154 | fun seqOnto (ts, ac) = | |
155 | Vector.foldr | |
156 | (ts, ac, fn (t, ac) => | |
157 | if Bits.equals (width t, Bits.zero) | |
158 | then ac | |
159 | else (case node t of | |
160 | Seq ts => seqOnto (ts, ac) | |
161 | | _ => (case ac of | |
162 | [] => [t] | |
163 | | t' :: ac' => | |
164 | (case (node t, node t') of | |
165 | (Bits, Bits) => | |
166 | bits (Bits.+ (width t, width t')) :: ac' | |
167 | | _ => t :: ac)))) | |
168 | in | |
169 | case seqOnto (ts, []) of | |
170 | [] => word0 | |
171 | | [t] => t | |
172 | | ts => | |
173 | let | |
174 | val ts = Vector.fromList ts | |
175 | in | |
176 | T {node = Seq ts, | |
177 | width = Vector.fold (ts, Bits.zero, fn (t, ac) => | |
178 | Bits.+ (ac, width t))} | |
179 | end | |
180 | end | |
181 | ||
182 | val seq = Trace.trace ("RepType.Type.seq", Vector.layout layout, layout) seq | |
183 | ||
184 | val sum: t vector -> t = | |
185 | fn ts => | |
186 | if Vector.isEmpty ts | |
187 | then Error.bug "RepType.Type.sum: empty" | |
188 | else | |
189 | let | |
190 | val opts = | |
191 | Vector.concatV | |
192 | (Vector.keepAllMap | |
193 | (ts, fn t => | |
194 | case node t of | |
195 | Objptr opts => SOME opts | |
196 | | _ => NONE)) | |
197 | in | |
198 | if Vector.isEmpty opts | |
199 | then Vector.first ts | |
200 | else | |
201 | T {node = (Objptr (QuickSort.sortVector (opts, ObjptrTycon.<=))), | |
202 | width = WordSize.bits (WordSize.objptr ())} | |
203 | end | |
204 | ||
205 | val sum = Trace.trace ("RepType.Type.sum", Vector.layout layout, layout) sum | |
206 | ||
207 | val intInf: unit -> t = fn () => | |
208 | sum (Vector.new2 | |
209 | (wordVector (WordSize.bigIntInfWord ()), | |
210 | seq (Vector.new2 | |
211 | (bits Bits.one, | |
212 | word (WordSize.fromBits | |
213 | (Bits.- (WordSize.bits (WordSize.smallIntInfWord ()), | |
214 | Bits.one))))))) | |
215 | ||
216 | val deLabel: t -> Label.t option = | |
217 | fn t => | |
218 | case node t of | |
219 | Label l => SOME l | |
220 | | _ => NONE | |
221 | ||
222 | val deObjptr: t -> ObjptrTycon.t option = | |
223 | fn t => | |
224 | case node t of | |
225 | Objptr opts => | |
226 | if 1 = Vector.length opts | |
227 | then SOME (Vector.first opts) | |
228 | else NONE | |
229 | | _ => NONE | |
230 | ||
231 | val deReal: t -> RealSize.t option = | |
232 | fn t => | |
233 | case node t of | |
234 | Real s => SOME s | |
235 | | _ => NONE | |
236 | ||
237 | val deSeq: t -> t vector option = | |
238 | fn t => | |
239 | case node t of | |
240 | Seq v => SOME v | |
241 | | _ => NONE | |
242 | ||
243 | val deWord: t -> WordSize.t option = | |
244 | fn t => | |
245 | case node t of | |
246 | Word s => SOME s | |
247 | | _ => NONE | |
248 | ||
249 | val isCPointer: t -> bool = | |
250 | fn t => | |
251 | case node t of | |
252 | CPointer => true | |
253 | | _ => false | |
254 | ||
255 | val isObjptr: t -> bool = | |
256 | fn t => | |
257 | case node t of | |
258 | Objptr _ => true | |
259 | | _ => false | |
260 | ||
261 | val isUnit: t -> bool = fn t => Bits.equals (Bits.zero, width t) | |
262 | ||
263 | val isSubtype: t * t -> bool = | |
264 | fn (t, t') => | |
265 | if not (sameWidth (t, t')) | |
266 | then false (* Error.bug "RepType.Type.isSubtype" *) | |
267 | else | |
268 | (equals (t, t') | |
269 | orelse | |
270 | case (node t, node t') of | |
271 | (Objptr opts, Objptr opts') => | |
272 | Vector.isSubsequence (opts, opts', ObjptrTycon.equals) | |
273 | | (Real _, _) => false | |
274 | | (Bits, Objptr _) => true | |
275 | | (Word _, Objptr _) => true | |
276 | | (Seq ts, Objptr _) => | |
277 | Vector.forall | |
278 | (ts, (fn Bits => true | |
279 | | Real _ => true | |
280 | | Word _ => true | |
281 | | _ => false) o node) | |
282 | | (_, Bits) => true | |
283 | | (_, Word _) => true | |
284 | | (_, Seq ts) => | |
285 | Vector.forall | |
286 | (ts, (fn Bits => true | |
287 | | Real _ => true | |
288 | | Word _ => true | |
289 | | _ => false) o node) | |
290 | | _ => false) | |
291 | ||
292 | val isSubtype = | |
293 | Trace.trace2 ("RepType.Type.isSubtype", layout, layout, Bool.layout) | |
294 | isSubtype | |
295 | ||
296 | fun exists (t, p) = | |
297 | if p t | |
298 | then true | |
299 | else (case node t of | |
300 | Seq ts => Vector.exists (ts, fn t => exists (t, p)) | |
301 | | _ => false) | |
302 | ||
303 | ||
304 | val resize: t * Bits.t -> t = fn (_, b) => bits b | |
305 | ||
306 | val bogusWord: t -> WordX.t = | |
307 | fn t => WordX.one (WordSize.fromBits (width t)) | |
308 | ||
309 | local | |
310 | structure C = | |
311 | struct | |
312 | open CType | |
313 | ||
314 | fun fromBits (b: Bits.t): t = | |
315 | case Bits.toInt b of | |
316 | 8 => Word8 | |
317 | | 16 => Word16 | |
318 | | 32 => Word32 | |
319 | | 64 => Word64 | |
320 | | _ => Error.bug (concat ["RepType.Type.CType.fromBits: ", | |
321 | Bits.toString b]) | |
322 | end | |
323 | in | |
324 | val toCType: t -> CType.t = | |
325 | fn t => | |
326 | if isObjptr t | |
327 | then C.Objptr | |
328 | else | |
329 | case node t of | |
330 | CPointer => C.CPointer | |
331 | | GCState => C.CPointer | |
332 | | Label _ => C.CPointer | |
333 | | Real s => | |
334 | (case s of | |
335 | RealSize.R32 => C.Real32 | |
336 | | RealSize.R64 => C.Real64) | |
337 | | _ => C.fromBits (width t) | |
338 | ||
339 | val name = C.name o toCType | |
340 | ||
341 | val align: t * Bytes.t -> Bytes.t = | |
342 | fn (t, n) => C.align (toCType t, n) | |
343 | end | |
344 | ||
345 | fun bytesAndObjptrs (t: t): Bytes.t * int = | |
346 | case node t of | |
347 | Objptr _ => (Bytes.zero, 1) | |
348 | | Seq ts => | |
349 | (case Vector.peeki (ts, isObjptr o #2) of | |
350 | NONE => (bytes t, 0) | |
351 | | SOME (i, _) => | |
352 | let | |
353 | val b = bytes (seq (Vector.prefix (ts, i))) | |
354 | val j = (Vector.length ts) - i | |
355 | in | |
356 | (b, j) | |
357 | end) | |
358 | | _ => (bytes t, 0) | |
359 | end | |
360 | ||
361 | structure ObjectType = | |
362 | struct | |
363 | structure ObjptrTycon = ObjptrTycon | |
364 | structure Runtime = Runtime | |
365 | ||
366 | type ty = Type.t | |
367 | datatype t = | |
368 | Array of {elt: ty, | |
369 | hasIdentity: bool} | |
370 | | Normal of {hasIdentity: bool, | |
371 | ty: ty} | |
372 | | Stack | |
373 | | Weak of Type.t option | |
374 | ||
375 | fun layout (t: t) = | |
376 | let | |
377 | open Layout | |
378 | in | |
379 | case t of | |
380 | Array {elt, hasIdentity} => | |
381 | seq [str "Array ", | |
382 | record [("elt", Type.layout elt), | |
383 | ("hasIdentity", Bool.layout hasIdentity)]] | |
384 | | Normal {hasIdentity, ty} => | |
385 | seq [str "Normal ", | |
386 | record [("hasIdentity", Bool.layout hasIdentity), | |
387 | ("ty", Type.layout ty)]] | |
388 | | Stack => str "Stack" | |
389 | | Weak t => seq [str "Weak ", Option.layout Type.layout t] | |
390 | end | |
391 | ||
392 | fun isOk (t: t): bool = | |
393 | case t of | |
394 | Array {elt, ...} => | |
395 | let | |
396 | val b = Type.width elt | |
397 | in | |
398 | Bits.isByteAligned b | |
399 | end | |
400 | | Normal {ty, ...} => | |
401 | let | |
402 | val b = Bits.+ (Type.width ty, | |
403 | Type.width (Type.objptrHeader ())) | |
404 | in | |
405 | case !Control.align of | |
406 | Control.Align4 => Bits.isWord32Aligned b | |
407 | | Control.Align8 => Bits.isWord64Aligned b | |
408 | end | |
409 | | Stack => true | |
410 | | Weak to => Option.fold (to, true, fn (t,_) => Type.isObjptr t) | |
411 | ||
412 | val stack = Stack | |
413 | ||
414 | val thread = fn () => | |
415 | let | |
416 | val padding = | |
417 | let | |
418 | val align = | |
419 | case !Control.align of | |
420 | Control.Align4 => Bytes.fromInt 4 | |
421 | | Control.Align8 => Bytes.fromInt 8 | |
422 | val bytesMetaData = | |
423 | Bits.toBytes (Control.Target.Size.normalMetaData ()) | |
424 | val bytesCSize = | |
425 | Bits.toBytes (Control.Target.Size.csize ()) | |
426 | val bytesExnStack = | |
427 | Bits.toBytes (Type.width (Type.exnStack ())) | |
428 | val bytesStack = | |
429 | Bits.toBytes (Type.width (Type.stack ())) | |
430 | ||
431 | val bytesObject = | |
432 | Bytes.+ (bytesMetaData, | |
433 | Bytes.+ (bytesCSize, | |
434 | Bytes.+ (bytesExnStack, | |
435 | bytesStack))) | |
436 | val bytesTotal = | |
437 | Bytes.align (bytesObject, {alignment = align}) | |
438 | val bytesPad = Bytes.- (bytesTotal, bytesObject) | |
439 | in | |
440 | Type.bits (Bytes.toBits bytesPad) | |
441 | end | |
442 | in | |
443 | Normal {hasIdentity = true, | |
444 | ty = Type.seq (Vector.new4 (padding, | |
445 | Type.csize (), | |
446 | Type.exnStack (), | |
447 | Type.stack ()))} | |
448 | end | |
449 | ||
450 | (* Order in the following vector matters. The basic pointer tycons must | |
451 | * correspond to the constants in gc/object.h. | |
452 | * STACK_TYPE_INDEX, | |
453 | * THREAD_TYPE_INDEX, | |
454 | * WEAK_GONE_TYPE_INDEX, | |
455 | * WORD8_VECTOR_TYPE_INDEX, | |
456 | * WORD16_VECTOR_TYPE_INDEX, | |
457 | * WORD32_VECTOR_TYPE_INDEX. | |
458 | * WORD64_VECTOR_TYPE_INDEX. | |
459 | *) | |
460 | val basic = fn () => | |
461 | let | |
462 | fun wordVec i = | |
463 | let | |
464 | val b = Bits.fromInt i | |
465 | in | |
466 | (ObjptrTycon.wordVector b, | |
467 | Array {hasIdentity = false, | |
468 | elt = Type.word (WordSize.fromBits b)}) | |
469 | end | |
470 | in | |
471 | Vector.fromList | |
472 | [(ObjptrTycon.stack, stack), | |
473 | (ObjptrTycon.thread, thread ()), | |
474 | (ObjptrTycon.weakGone, Weak NONE), | |
475 | wordVec 8, | |
476 | wordVec 32, | |
477 | wordVec 16, | |
478 | wordVec 64] | |
479 | end | |
480 | ||
481 | local | |
482 | structure R = Runtime.RObjectType | |
483 | in | |
484 | fun toRuntime (t: t): R.t = | |
485 | case t of | |
486 | Array {elt, hasIdentity} => | |
487 | let | |
488 | val (b, nops) = Type.bytesAndObjptrs elt | |
489 | in | |
490 | R.Array {hasIdentity = hasIdentity, | |
491 | bytesNonObjptrs = b, | |
492 | numObjptrs = nops} | |
493 | end | |
494 | | Normal {hasIdentity, ty} => | |
495 | let | |
496 | val (b, nops) = Type.bytesAndObjptrs ty | |
497 | in | |
498 | R.Normal {hasIdentity = hasIdentity, | |
499 | bytesNonObjptrs = b, | |
500 | numObjptrs = nops} | |
501 | end | |
502 | | Stack => R.Stack | |
503 | | Weak to => R.Weak {gone = Option.isNone to} | |
504 | end | |
505 | end | |
506 | ||
507 | open Type | |
508 | ||
509 | structure GCField = Runtime.GCField | |
510 | ||
511 | fun ofGCField (f: GCField.t): t = | |
512 | let | |
513 | datatype z = datatype GCField.t | |
514 | in | |
515 | case f of | |
516 | AtomicState => word32 | |
517 | | CardMapAbsolute => cpointer () | |
518 | | CurrentThread => thread () | |
519 | | CurSourceSeqsIndex => word32 | |
520 | | ExnStack => exnStack () | |
521 | | Frontier => cpointer () | |
522 | | Limit => cpointer () | |
523 | | LimitPlusSlop => cpointer () | |
524 | | MaxFrameSize => word32 | |
525 | | SignalIsPending => word32 | |
526 | | StackBottom => cpointer () | |
527 | | StackLimit => cpointer () | |
528 | | StackTop => cpointer () | |
529 | end | |
530 | ||
531 | fun castIsOk {from, to, tyconTy = _} = | |
532 | Bits.equals (width from, width to) | |
533 | ||
534 | fun checkPrimApp {args, prim, result} = | |
535 | let | |
536 | datatype z = datatype Prim.Name.t | |
537 | fun done (argsP, resultP) = | |
538 | let | |
539 | val argsP = Vector.fromList argsP | |
540 | in | |
541 | (Vector.length args = Vector.length argsP) | |
542 | andalso (Vector.forall2 (args, argsP, | |
543 | fn (arg, argP) => argP arg)) | |
544 | andalso (case (result, resultP) of | |
545 | (NONE, NONE) => true | |
546 | | (SOME result, SOME resultP) => resultP result | |
547 | | _ => false) | |
548 | end | |
549 | val bits = fn s => fn t => equals (t, bits s) | |
550 | val bool = fn t => equals (t, bool) | |
551 | val cpointer = fn t => equals (t, cpointer ()) | |
552 | val objptr = fn t => (case node t of Objptr _ => true | _ => false) | |
553 | val real = fn s => fn t => equals (t, real s) | |
554 | val seq = fn s => fn t => | |
555 | (case node t | |
556 | of Seq _ => Bits.equals (width t, WordSize.bits s) | |
557 | | _ => false) | |
558 | val word = fn s => fn t => equals (t, word s) | |
559 | ||
560 | val cint = word (WordSize.cint ()) | |
561 | val csize = word (WordSize.csize ()) | |
562 | val cptrdiff = word (WordSize.cptrdiff ()) | |
563 | val shiftArg = word WordSize.shiftArg | |
564 | ||
565 | val or = fn (p1, p2) => fn t => p1 t orelse p2 t | |
566 | val bitsOrSeq = fn s => or (bits (WordSize.bits s), seq s) | |
567 | val wordOrBitsOrSeq = fn s => or (word s, bitsOrSeq s) | |
568 | local | |
569 | fun make f s = let val t = f s in done ([t], SOME t) end | |
570 | in | |
571 | val realUnary = make real | |
572 | val wordUnary = make wordOrBitsOrSeq | |
573 | end | |
574 | local | |
575 | fun make f s = let val t = f s in done ([t, t], SOME t) end | |
576 | in | |
577 | val realBinary = make real | |
578 | val wordBinary = make wordOrBitsOrSeq | |
579 | end | |
580 | local | |
581 | fun make f s = let val t = f s in done ([t, t], SOME bool) end | |
582 | in | |
583 | val realCompare = make real | |
584 | val wordCompare = make wordOrBitsOrSeq | |
585 | val objptrCompare = make (fn _ => objptr) () | |
586 | end | |
587 | fun realTernary s = done ([real s, real s, real s], SOME (real s)) | |
588 | fun wordShift s = done ([wordOrBitsOrSeq s, shiftArg], SOME (wordOrBitsOrSeq s)) | |
589 | in | |
590 | case Prim.name prim of | |
591 | CPointer_add => done ([cpointer, cptrdiff], SOME cpointer) | |
592 | | CPointer_diff => done ([cpointer, cpointer], SOME cptrdiff) | |
593 | | CPointer_equal => done ([cpointer, cpointer], SOME bool) | |
594 | | CPointer_fromWord => done ([csize], SOME cpointer) | |
595 | | CPointer_lt => done ([cpointer, cpointer], SOME bool) | |
596 | | CPointer_sub => done ([cpointer, cptrdiff], SOME cpointer) | |
597 | | CPointer_toWord => done ([cpointer], SOME csize) | |
598 | | FFI f => done (Vector.toListMap (CFunction.args f, | |
599 | fn t' => fn t => equals (t', t)), | |
600 | SOME (fn t => equals (t, CFunction.return f))) | |
601 | | FFI_Symbol _ => done ([], SOME cpointer) | |
602 | | MLton_touch => done ([objptr], NONE) | |
603 | | Real_Math_acos s => realUnary s | |
604 | | Real_Math_asin s => realUnary s | |
605 | | Real_Math_atan s => realUnary s | |
606 | | Real_Math_atan2 s => realBinary s | |
607 | | Real_Math_cos s => realUnary s | |
608 | | Real_Math_exp s => realUnary s | |
609 | | Real_Math_ln s => realUnary s | |
610 | | Real_Math_log10 s => realUnary s | |
611 | | Real_Math_sin s => realUnary s | |
612 | | Real_Math_sqrt s => realUnary s | |
613 | | Real_Math_tan s => realUnary s | |
614 | | Real_abs s => realUnary s | |
615 | | Real_add s => realBinary s | |
616 | | Real_castToWord (s, s') => done ([real s], SOME (word s')) | |
617 | | Real_div s => realBinary s | |
618 | | Real_equal s => realCompare s | |
619 | | Real_ldexp s => done ([real s, cint], SOME (real s)) | |
620 | | Real_le s => realCompare s | |
621 | | Real_lt s => realCompare s | |
622 | | Real_mul s => realBinary s | |
623 | | Real_muladd s => realTernary s | |
624 | | Real_mulsub s => realTernary s | |
625 | | Real_neg s => realUnary s | |
626 | | Real_qequal s => realCompare s | |
627 | | Real_rndToReal (s, s') => done ([real s], SOME (real s')) | |
628 | | Real_rndToWord (s, s', _) => done ([real s], SOME (word s')) | |
629 | | Real_round s => realUnary s | |
630 | | Real_sub s => realBinary s | |
631 | | Thread_returnToC => done ([], NONE) | |
632 | | Word_add s => wordBinary s | |
633 | | Word_addCheck (s, _) => wordBinary s | |
634 | | Word_andb s => wordBinary s | |
635 | | Word_castToReal (s, s') => done ([word s], SOME (real s')) | |
636 | | Word_equal s => (wordCompare s) orelse objptrCompare | |
637 | | Word_extdToWord (s, s', _) => done ([wordOrBitsOrSeq s], | |
638 | SOME (wordOrBitsOrSeq s')) | |
639 | | Word_lshift s => wordShift s | |
640 | | Word_lt (s, _) => wordCompare s | |
641 | | Word_mul (s, _) => wordBinary s | |
642 | | Word_mulCheck (s, _) => wordBinary s | |
643 | | Word_neg s => wordUnary s | |
644 | | Word_negCheck s => wordUnary s | |
645 | | Word_notb s => wordUnary s | |
646 | | Word_orb s => wordBinary s | |
647 | | Word_quot (s, _) => wordBinary s | |
648 | | Word_rem (s, _) => wordBinary s | |
649 | | Word_rndToReal (s, s', _) => done ([word s], SOME (real s')) | |
650 | | Word_rol s => wordShift s | |
651 | | Word_ror s => wordShift s | |
652 | | Word_rshift (s, _) => wordShift s | |
653 | | Word_sub s => wordBinary s | |
654 | | Word_subCheck (s, _) => wordBinary s | |
655 | | Word_xorb s => wordBinary s | |
656 | | _ => Error.bug (concat ["RepType.checkPrimApp got strange prim: ", | |
657 | Prim.toString prim]) | |
658 | end | |
659 | ||
660 | fun checkOffset {base, isVector, offset, result} = | |
661 | Exn.withEscape (fn escape => | |
662 | let | |
663 | fun getTys ty = | |
664 | case node ty of | |
665 | Seq tys => Vector.toList tys | |
666 | | _ => [ty] | |
667 | ||
668 | fun dropTys (tys, bits) = | |
669 | let | |
670 | fun loop (tys, bits) = | |
671 | if Bits.equals (bits, Bits.zero) | |
672 | then tys | |
673 | else (case tys of | |
674 | [] => escape false | |
675 | | ty::tys => | |
676 | let | |
677 | val b = width ty | |
678 | in | |
679 | if Bits.>= (bits, b) | |
680 | then loop (tys, Bits.- (bits, b)) | |
681 | else (case node ty of | |
682 | Bits => (Type.bits (Bits.- (b, bits))) :: tys | |
683 | | _ => escape false) | |
684 | end) | |
685 | in | |
686 | if Bits.< (bits, Bits.zero) | |
687 | then escape false | |
688 | else loop (tys, bits) | |
689 | end | |
690 | val dropTys = | |
691 | Trace.trace2 | |
692 | ("RepType.checkOffset.dropTys", | |
693 | List.layout Type.layout, Bits.layout, | |
694 | List.layout Type.layout) | |
695 | dropTys | |
696 | fun takeTys (tys, bits) = | |
697 | let | |
698 | fun loop (tys, bits, acc) = | |
699 | if Bits.equals (bits, Bits.zero) | |
700 | then acc | |
701 | else (case tys of | |
702 | [] => escape false | |
703 | | ty::tys => | |
704 | let | |
705 | val b = width ty | |
706 | in | |
707 | if Bits.>= (bits, b) | |
708 | then loop (tys, Bits.- (bits, b), ty :: acc) | |
709 | else (case node ty of | |
710 | Bits => (Type.bits bits) :: acc | |
711 | | _ => escape false) | |
712 | end) | |
713 | in | |
714 | if Bits.< (bits, Bits.zero) | |
715 | then escape false | |
716 | else List.rev (loop (tys, bits, [])) | |
717 | end | |
718 | fun extractTys (tys, dropBits, takeBits) = | |
719 | takeTys (dropTys (tys, dropBits), takeBits) | |
720 | ||
721 | fun equalsTys (tys1, tys2) = | |
722 | case (tys1, tys2) of | |
723 | ([], []) => true | |
724 | | (ty1::tys1, ty2::tys2) => | |
725 | equals (ty1, ty2) | |
726 | andalso equalsTys (tys1, tys2) | |
727 | | _ => false | |
728 | ||
729 | val alignBits = | |
730 | case !Control.align of | |
731 | Control.Align4 => Bits.inWord32 | |
732 | | Control.Align8 => Bits.inWord64 | |
733 | ||
734 | val baseBits = width base | |
735 | val baseTys = getTys base | |
736 | ||
737 | val offsetBytes = offset | |
738 | val offsetBits = Bytes.toBits offsetBytes | |
739 | ||
740 | val resultBits = width result | |
741 | val resultTys = getTys result | |
742 | ||
743 | val adjOffsetBits = | |
744 | if Control.Target.bigEndian () | |
745 | andalso Bits.< (resultBits, Bits.inWord32) | |
746 | andalso Bits.> (baseBits, resultBits) | |
747 | then let | |
748 | val paddedComponentBits = | |
749 | if isVector | |
750 | then Bits.min (baseBits, Bits.inWord32) | |
751 | else Bits.inWord32 | |
752 | val paddedComponentOffsetBits = | |
753 | Bits.alignDown (offsetBits, {alignment = paddedComponentBits}) | |
754 | in | |
755 | Bits.+ (paddedComponentOffsetBits, | |
756 | Bits.- (paddedComponentBits, | |
757 | Bits.- (Bits.+ (resultBits, offsetBits), | |
758 | paddedComponentOffsetBits))) | |
759 | end | |
760 | else offsetBits | |
761 | in | |
762 | List.exists | |
763 | ([Bits.inWord8, Bits.inWord16, Bits.inWord32, Bits.inWord64], fn primBits => | |
764 | Bits.equals (resultBits, primBits) | |
765 | andalso Bits.isAligned (offsetBits, {alignment = Bits.min (primBits, alignBits)})) | |
766 | andalso | |
767 | equalsTys (resultTys, extractTys (baseTys, adjOffsetBits, resultBits)) | |
768 | end) | |
769 | ||
770 | fun offsetIsOk {base, offset, tyconTy, result} = | |
771 | case node base of | |
772 | Objptr opts => | |
773 | if Bytes.equals (offset, Runtime.headerOffset ()) | |
774 | then equals (result, objptrHeader ()) | |
775 | else if Bytes.equals (offset, Runtime.arrayLengthOffset ()) | |
776 | then (1 = Vector.length opts) | |
777 | andalso (case tyconTy (Vector.sub (opts, 0)) of | |
778 | ObjectType.Array _ => true | |
779 | | _ => false) | |
780 | andalso (equals (result, seqIndex ())) | |
781 | else (1 = Vector.length opts) | |
782 | andalso (case tyconTy (Vector.sub (opts, 0)) of | |
783 | ObjectType.Normal {ty, ...} => | |
784 | checkOffset {base = ty, | |
785 | isVector = false, | |
786 | offset = offset, | |
787 | result = result} | |
788 | | _ => false) | |
789 | | _ => false | |
790 | ||
791 | fun arrayOffsetIsOk {base, index, offset, tyconTy, result, scale} = | |
792 | case node base of | |
793 | CPointer => | |
794 | (equals (index, csize ())) | |
795 | andalso (case node result of | |
796 | CPointer => true | |
797 | | Objptr _ => true (* for FFI export of indirect types *) | |
798 | | Real _ => true | |
799 | | Word _ => true | |
800 | | _ => false) | |
801 | andalso (case Scale.fromBytes (bytes result) of | |
802 | NONE => false | |
803 | | SOME s => scale = s) | |
804 | andalso (Bytes.equals (offset, Bytes.zero)) | |
805 | | Objptr opts => | |
806 | (equals (index, seqIndex ())) | |
807 | andalso (1 = Vector.length opts) | |
808 | andalso (case tyconTy (Vector.first opts) of | |
809 | ObjectType.Array {elt, ...} => | |
810 | if equals (elt, word8) | |
811 | then (* special case for PackWord operations *) | |
812 | (case node result of | |
813 | Word wsRes => | |
814 | (case Scale.fromBytes (WordSize.bytes wsRes) of | |
815 | NONE => false | |
816 | | SOME s => scale = s) | |
817 | andalso (Bytes.equals (offset, Bytes.zero)) | |
818 | | _ => false) | |
819 | else (case Scale.fromBytes (bytes elt) of | |
820 | NONE => scale = Scale.One | |
821 | | SOME s => scale = s) | |
822 | andalso (checkOffset {base = elt, | |
823 | isVector = true, | |
824 | offset = offset, | |
825 | result = result}) | |
826 | | _ => false) | |
827 | | _ => false | |
828 | ||
829 | ||
830 | ||
831 | structure BuiltInCFunction = | |
832 | struct | |
833 | open CFunction | |
834 | ||
835 | datatype z = datatype Convention.t | |
836 | datatype z = datatype Target.t | |
837 | ||
838 | fun bug () = | |
839 | vanilla {args = Vector.new1 (string ()), | |
840 | name = "MLton_bug", | |
841 | prototype = (Vector.new1 CType.objptr, NONE), | |
842 | return = unit} | |
843 | ||
844 | local | |
845 | fun make b = fn () => | |
846 | T {args = Vector.new3 (Type.gcState (), Type.csize (), Type.bool), | |
847 | convention = Cdecl, | |
848 | kind = Kind.Runtime {bytesNeeded = NONE, | |
849 | ensuresBytesFree = true, | |
850 | mayGC = true, | |
851 | maySwitchThreads = b, | |
852 | modifiesFrontier = true, | |
853 | readsStackTop = true, | |
854 | writesStackTop = true}, | |
855 | prototype = (Vector.new3 (CType.cpointer, CType.csize (), CType.bool), | |
856 | NONE), | |
857 | return = Type.unit, | |
858 | symbolScope = SymbolScope.Private, | |
859 | target = Direct "GC_collect"} | |
860 | val t = make true | |
861 | val f = make false | |
862 | in | |
863 | fun gc {maySwitchThreads = b} = if b then t () else f () | |
864 | end | |
865 | end | |
866 | ||
867 | end |