Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2016-2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | (* Has a special case to make sure that true is represented as 1 | |
11 | * and false is represented as 0. | |
12 | *) | |
13 | ||
14 | functor PackedRepresentation (S: REPRESENTATION_STRUCTS): REPRESENTATION = | |
15 | struct | |
16 | ||
17 | open S | |
18 | ||
19 | local | |
20 | open Rssa | |
21 | in | |
22 | structure Block = Block | |
23 | structure Kind = Kind | |
24 | structure Label = Label | |
25 | structure ObjectType = ObjectType | |
26 | structure Operand = Operand | |
27 | structure ObjptrTycon = ObjptrTycon | |
28 | structure Prim = Prim | |
29 | structure RealSize = RealSize | |
30 | structure Runtime = Runtime | |
31 | structure Scale = Scale | |
32 | structure Statement = Statement | |
33 | structure Switch = Switch | |
34 | structure Transfer = Transfer | |
35 | structure Type = Type | |
36 | structure Var = Var | |
37 | structure WordSize = WordSize | |
38 | structure WordX = WordX | |
39 | end | |
40 | structure S = Ssa | |
41 | local | |
42 | open Ssa | |
43 | in | |
44 | structure Base = Base | |
45 | structure Con = Con | |
46 | structure ObjectCon = ObjectCon | |
47 | structure Prod = Prod | |
48 | structure Tycon = Tycon | |
49 | end | |
50 | ||
51 | datatype z = datatype Operand.t | |
52 | datatype z = datatype Statement.t | |
53 | datatype z = datatype Transfer.t | |
54 | ||
55 | structure Type = | |
56 | struct | |
57 | open Type | |
58 | ||
59 | local | |
60 | fun mkPadToCheck (t: t, mk): (Bits.t * (unit -> t) -> t) = | |
61 | let | |
62 | val b = width t | |
63 | fun check (b', continue) = | |
64 | if Bits.< (b, b') | |
65 | then let | |
66 | val pad = zero (Bits.- (b', b)) | |
67 | in | |
68 | mk (t, pad) | |
69 | end | |
70 | else if Bits.equals (b, b') | |
71 | then t | |
72 | else continue () | |
73 | in | |
74 | check | |
75 | end | |
76 | fun mkPadToPrim (t: t, mk): t = | |
77 | let | |
78 | val check = mkPadToCheck (t, mk) | |
79 | in | |
80 | check (Bits.zero, fn () => | |
81 | check (Bits.inWord8, fn () => | |
82 | check (Bits.inWord16, fn () => | |
83 | check (Bits.inWord32, fn () => | |
84 | check (Bits.inWord64, fn () => | |
85 | Error.bug "PackedRepresentation.Type.mkPadToPrim"))))) | |
86 | end | |
87 | fun mkPadToWidth (t: t, b': Bits.t, mk): t = | |
88 | let | |
89 | val check = mkPadToCheck (t, mk) | |
90 | in | |
91 | check (b', fn () => | |
92 | Error.bug "PackedRepresentation.Type.mkPadToWidth") | |
93 | end | |
94 | fun mk (t, pad) = seq (Vector.new2 (t, pad)) | |
95 | fun mkLow (t, pad) = seq (Vector.new2 (pad, t)) | |
96 | in | |
97 | fun padToPrim (t: t): t = mkPadToPrim (t, mk) | |
98 | fun padToPrimLow (t: t): t = mkPadToPrim (t, mkLow) | |
99 | fun padToWidth (t: t, b: Bits.t): t = mkPadToWidth (t, b, mk) | |
100 | fun padToWidthLow (t: t, b: Bits.t): t = mkPadToWidth (t, b, mkLow) | |
101 | end | |
102 | ||
103 | val padToPrim = | |
104 | Trace.trace | |
105 | ("PackedRepresentation.Type.padToPrim", layout, layout) | |
106 | padToPrim | |
107 | val padToPrimLow = | |
108 | Trace.trace | |
109 | ("PackedRepresentation.Type.padToPrimLow", layout, layout) | |
110 | padToPrimLow | |
111 | val padToWidth = | |
112 | Trace.trace2 | |
113 | ("PackedRepresentation.Type.padToWidth", layout, Bits.layout, layout) | |
114 | padToWidth | |
115 | val padToWidthLow = | |
116 | Trace.trace2 | |
117 | ("PackedRepresentation.Type.padToWidthLow", layout, Bits.layout, layout) | |
118 | padToWidthLow | |
119 | ||
120 | end | |
121 | ||
122 | structure Rep = | |
123 | struct | |
124 | datatype rep = | |
125 | NonObjptr | |
126 | | Objptr of {endsIn00: bool} | |
127 | ||
128 | datatype t = T of {rep: rep, | |
129 | ty: Type.t} | |
130 | ||
131 | fun layout (T {rep, ty}) = | |
132 | let | |
133 | open Layout | |
134 | in | |
135 | record [("rep", | |
136 | case rep of | |
137 | NonObjptr => str "NonObjptr" | |
138 | | Objptr {endsIn00} => | |
139 | seq [str "Objptr ", | |
140 | record [("endsIn00", Bool.layout endsIn00)]]), | |
141 | ("ty", Type.layout ty)] | |
142 | end | |
143 | ||
144 | local | |
145 | fun make f (T r) = f r | |
146 | in | |
147 | val ty = make #ty | |
148 | val rep = make #rep | |
149 | end | |
150 | ||
151 | fun equals (r, r') = Type.equals (ty r, ty r') | |
152 | ||
153 | val equals = | |
154 | Trace.trace2 | |
155 | ("PackedRepresentation.Rep.equals", layout, layout, Bool.layout) | |
156 | equals | |
157 | ||
158 | fun nonObjptr ty = T {rep = NonObjptr, | |
159 | ty = ty} | |
160 | ||
161 | val bool = nonObjptr Type.bool | |
162 | ||
163 | val width = Type.width o ty | |
164 | ||
165 | val unit = T {rep = NonObjptr, | |
166 | ty = Type.unit} | |
167 | ||
168 | fun isObjptr (T {rep, ...}) = | |
169 | case rep of | |
170 | Objptr _ => true | |
171 | | _ => false | |
172 | ||
173 | fun isObjptrEndingIn00 (T {rep, ...}) = | |
174 | case rep of | |
175 | Objptr {endsIn00} => endsIn00 | |
176 | | _ => false | |
177 | ||
178 | fun padToWidth (r as T {rep, ty}, width: Bits.t) = | |
179 | if Bits.equals (Type.width ty, width) | |
180 | then r | |
181 | else | |
182 | case rep of | |
183 | NonObjptr => | |
184 | T {rep = NonObjptr, | |
185 | ty = Type.padToWidth (ty, width)} | |
186 | | Objptr _ => Error.bug "PackedRepresentation.Rep.padToWidth" | |
187 | ||
188 | fun padToWidthLow (r as T {rep, ty}, width: Bits.t) = | |
189 | if Bits.equals (Type.width ty, width) | |
190 | then r | |
191 | else | |
192 | case rep of | |
193 | NonObjptr => | |
194 | T {rep = NonObjptr, | |
195 | ty = Type.padToWidthLow (ty, width)} | |
196 | | Objptr _ => Error.bug "PackedRepresentation.Rep.padToWidth" | |
197 | end | |
198 | ||
199 | structure Statement = | |
200 | struct | |
201 | open Statement | |
202 | ||
203 | local | |
204 | fun make prim (z1: Operand.t, z2: Operand.t) = | |
205 | let | |
206 | val ty = Operand.ty z1 | |
207 | val tmp = Var.newNoname () | |
208 | in | |
209 | (PrimApp {args = Vector.new2 (z1, z2), | |
210 | dst = SOME (tmp, ty), | |
211 | prim = prim (WordSize.fromBits (Type.width ty))}, | |
212 | Var {ty = ty, var = tmp}) | |
213 | end | |
214 | in | |
215 | val andb = make Prim.wordAndb | |
216 | val lshift = make Prim.wordLshift | |
217 | val orb = make Prim.wordOrb | |
218 | val rshift = make (fn s => Prim.wordRshift (s, {signed = false})) | |
219 | end | |
220 | end | |
221 | ||
222 | structure WordRep = | |
223 | struct | |
224 | (* WordRep describes the representation of (some of) the components in a | |
225 | * tuple as a word. | |
226 | * Components are stored from lowest to highest, just like in Type.seq. | |
227 | * The width of the rep must be less than the width of an objptr. | |
228 | * The sum of the widths of the component reps must be equal to the | |
229 | * width of the rep. | |
230 | *) | |
231 | datatype t = T of {components: {index: int, | |
232 | rep: Rep.t} vector, | |
233 | rep: Rep.t} | |
234 | ||
235 | fun layout (T {components, rep}) = | |
236 | let | |
237 | open Layout | |
238 | in | |
239 | record [("components", | |
240 | Vector.layout (fn {index, rep} => | |
241 | record [("index", Int.layout index), | |
242 | ("rep", Rep.layout rep)]) | |
243 | components), | |
244 | ("rep", Rep.layout rep)] | |
245 | end | |
246 | ||
247 | local | |
248 | fun make f (T r) = f r | |
249 | in | |
250 | val rep = make #rep | |
251 | end | |
252 | ||
253 | val unit = T {components = Vector.new0 (), | |
254 | rep = Rep.unit} | |
255 | ||
256 | fun equals (wr, wr') = Rep.equals (rep wr, rep wr') | |
257 | ||
258 | fun make {components, rep} = | |
259 | if Bits.<= (Rep.width rep, Control.Target.Size.objptr ()) | |
260 | andalso Bits.equals (Vector.fold (components, Bits.zero, | |
261 | fn ({rep, ...}, ac) => | |
262 | Bits.+ (ac, Rep.width rep)), | |
263 | Rep.width rep) | |
264 | then T {components = components, | |
265 | rep = rep} | |
266 | else Error.bug "PackedRepresentation.WordRep.make" | |
267 | ||
268 | val make = | |
269 | Trace.trace | |
270 | ("PackedRepresentation.WordRep.make", | |
271 | layout o T, | |
272 | layout) | |
273 | make | |
274 | ||
275 | fun padToWidth (T {components, rep}, b: Bits.t): t = | |
276 | let | |
277 | val newRep = Rep.padToWidth (rep, b) | |
278 | val padBits = Bits.- (Rep.width newRep, Rep.width rep) | |
279 | val newComponent = | |
280 | {index = ~1, | |
281 | rep = Rep.nonObjptr (Type.bits padBits)} | |
282 | val newComponents = | |
283 | Vector.concat | |
284 | [components, Vector.new1 newComponent] | |
285 | in | |
286 | make {components = newComponents, | |
287 | rep = newRep} | |
288 | end | |
289 | fun padToWidthLow (T {components, rep}, b: Bits.t): t = | |
290 | let | |
291 | val newRep = Rep.padToWidthLow (rep, b) | |
292 | val padBits = Bits.- (Rep.width newRep, Rep.width rep) | |
293 | val newComponent = | |
294 | {index = ~1, | |
295 | rep = Rep.nonObjptr (Type.bits padBits)} | |
296 | val newComponents = | |
297 | Vector.concat | |
298 | [Vector.new1 newComponent, components] | |
299 | in | |
300 | make {components = newComponents, | |
301 | rep = newRep} | |
302 | end | |
303 | ||
304 | fun tuple (T {components, ...}, | |
305 | {dst = (dstVar, dstTy): Var.t * Type.t, | |
306 | src: {index: int} -> Operand.t}): Statement.t list = | |
307 | let | |
308 | val bits = Type.width dstTy | |
309 | val (accOpt,_,statements) = | |
310 | Vector.fold | |
311 | (components, (NONE,Bits.zero,[]), | |
312 | fn ({index, rep, ...}, (accOpt,shift,statements)) => | |
313 | if index < 0 | |
314 | then (accOpt, Bits.+ (shift, Rep.width rep), statements) | |
315 | else | |
316 | let | |
317 | val (src, ss) = Statement.resize (src {index = index}, | |
318 | Type.bits bits) | |
319 | val ss = List.rev ss | |
320 | val (src, ss) = | |
321 | if Bits.equals (shift, Bits.zero) | |
322 | then (src, ss) | |
323 | else let | |
324 | val (s, src) = | |
325 | Statement.lshift | |
326 | (src, | |
327 | Operand.word | |
328 | (WordX.fromIntInf (Bits.toIntInf shift, | |
329 | WordSize.shiftArg))) | |
330 | in | |
331 | (src, s :: ss) | |
332 | end | |
333 | val (acc, ss) = | |
334 | case accOpt of | |
335 | NONE => (src, ss) | |
336 | | SOME acc => | |
337 | let | |
338 | val (s, acc) = Statement.orb (src, acc) | |
339 | in | |
340 | (acc, s :: ss) | |
341 | end | |
342 | in | |
343 | (SOME acc, Bits.+ (shift, Rep.width rep), ss :: statements) | |
344 | end) | |
345 | val statements = | |
346 | case accOpt of | |
347 | NONE => [] | |
348 | | SOME src => | |
349 | [Bind {dst = (dstVar, dstTy), | |
350 | isMutable = false, | |
351 | src = src}] | |
352 | :: statements | |
353 | in | |
354 | List.fold (statements, [], fn (ss, ac) => List.fold (ss, ac, op ::)) | |
355 | end | |
356 | ||
357 | val tuple = | |
358 | Trace.trace | |
359 | ("PackedRepresentation.WordRep.tuple", | |
360 | layout o #1, List.layout Statement.layout) | |
361 | tuple | |
362 | end | |
363 | ||
364 | structure Component = | |
365 | struct | |
366 | datatype t = | |
367 | Direct of {index: int, | |
368 | rep: Rep.t} | |
369 | | Word of WordRep.t | |
370 | ||
371 | fun layout c = | |
372 | let | |
373 | open Layout | |
374 | in | |
375 | case c of | |
376 | Direct {index, rep} => | |
377 | seq [str "Direct ", | |
378 | record [("index", Int.layout index), | |
379 | ("rep", Rep.layout rep)]] | |
380 | | Word wr => | |
381 | seq [str "Word ", WordRep.layout wr] | |
382 | end | |
383 | ||
384 | val rep: t -> Rep.t = | |
385 | fn Direct {rep, ...} => rep | |
386 | | Word wr => WordRep.rep wr | |
387 | ||
388 | val ty = Rep.ty o rep | |
389 | ||
390 | val unit = Word WordRep.unit | |
391 | ||
392 | val equals: t * t -> bool = | |
393 | fn z => | |
394 | case z of | |
395 | (Direct {rep = r, ...}, Direct {rep = r', ...}) => Rep.equals (r, r') | |
396 | | (Word wr, Word wr') => WordRep.equals (wr, wr') | |
397 | | _ => false | |
398 | ||
399 | local | |
400 | fun mkPadToWidth (c: t, b: Bits.t, repPadToWidth, wordRepPadToWidth): t = | |
401 | case c of | |
402 | Direct {index, rep} => | |
403 | Direct {index = index, | |
404 | rep = repPadToWidth (rep, b)} | |
405 | | Word r => Word (wordRepPadToWidth (r, b)) | |
406 | in | |
407 | fun padToWidth (c, b) = | |
408 | mkPadToWidth (c, b, Rep.padToWidth, WordRep.padToWidth) | |
409 | fun padToWidthLow (c, b) = | |
410 | mkPadToWidth (c, b, Rep.padToWidthLow, WordRep.padToWidthLow) | |
411 | end | |
412 | ||
413 | local | |
414 | fun mkPadToPrim (c: t, typePadToPrim, padToWidth) = | |
415 | let | |
416 | val ty = ty c | |
417 | val ty' = typePadToPrim ty | |
418 | in | |
419 | if Type.equals (ty, ty') | |
420 | then c | |
421 | else padToWidth (c, Type.width ty') | |
422 | end | |
423 | in | |
424 | fun padToPrim c = mkPadToPrim (c, Type.padToPrim, padToWidth) | |
425 | fun padToPrimLow c = mkPadToPrim (c, Type.padToPrimLow, padToWidthLow) | |
426 | end | |
427 | ||
428 | fun tuple (c: t, {dst: Var.t * Type.t, | |
429 | src: {index: int} -> Operand.t}) | |
430 | : Statement.t list = | |
431 | case c of | |
432 | Direct {index, ...} => | |
433 | let | |
434 | val (src, ss) = | |
435 | Statement.resize (src {index = index}, #2 dst) | |
436 | in | |
437 | ss @ [Bind {dst = dst, | |
438 | isMutable = false, | |
439 | src = src}] | |
440 | end | |
441 | | Word wr => WordRep.tuple (wr, {dst = dst, src = src}) | |
442 | ||
443 | val tuple = | |
444 | Trace.trace2 | |
445 | ("PackedRepresentation.Component.tuple", | |
446 | layout, | |
447 | fn {dst = (dst, _), ...} => Var.layout dst, | |
448 | List.layout Statement.layout) | |
449 | tuple | |
450 | end | |
451 | ||
452 | structure Unpack = | |
453 | struct | |
454 | datatype t = T of {shift: Bits.t, | |
455 | ty: Type.t} | |
456 | ||
457 | fun layout (T {shift, ty}) = | |
458 | let | |
459 | open Layout | |
460 | in | |
461 | record [("shift", Bits.layout shift), | |
462 | ("ty", Type.layout ty)] | |
463 | end | |
464 | ||
465 | val lshift: t * Bits.t -> t = | |
466 | fn (T {shift, ty}, b) => | |
467 | T {shift = Bits.+ (shift, b), | |
468 | ty = ty} | |
469 | ||
470 | fun select (T {shift, ty}, | |
471 | {dst = (dst, dstTy), | |
472 | src: Operand.t}): Statement.t list = | |
473 | let | |
474 | val (src, ss1) = | |
475 | if Bits.isZero shift | |
476 | then (src, []) | |
477 | else | |
478 | let | |
479 | val shift = | |
480 | WordX.fromIntInf (Bits.toIntInf shift, WordSize.shiftArg) | |
481 | val (s, tmp) = Statement.rshift (src, Operand.word shift) | |
482 | in | |
483 | (tmp, [s]) | |
484 | end | |
485 | val w = Type.width ty | |
486 | val sz = WordSize.fromBits w | |
487 | val w' = Type.width dstTy | |
488 | val sz' = WordSize.fromBits w' | |
489 | val (src, ss2) = Statement.resize (src, dstTy) | |
490 | val (src, ss3) = | |
491 | if Bits.equals (w, w') | |
492 | (* orelse Type.isZero (Type.dropPrefix (Operand.ty src, | |
493 | * WordSize.bits sz)) | |
494 | *) | |
495 | then (src, []) | |
496 | else | |
497 | let | |
498 | val mask = WordX.resize (WordX.max (sz, {signed = false}), sz') | |
499 | val (s, src) = Statement.andb (src, Operand.word mask) | |
500 | in | |
501 | (src, [s]) | |
502 | end | |
503 | in | |
504 | ss1 @ ss2 @ ss3 @ [Bind {dst = (dst, dstTy), | |
505 | isMutable = false, | |
506 | src = src}] | |
507 | end | |
508 | ||
509 | val select = | |
510 | Trace.trace2 | |
511 | ("PackedRepresentation.Unpack.select", | |
512 | layout, | |
513 | fn {dst = (dst, _), src} => | |
514 | Layout.record [("dst", Var.layout dst), | |
515 | ("src", Operand.layout src)], | |
516 | List.layout Statement.layout) | |
517 | select | |
518 | ||
519 | fun update (T {shift, ty}, | |
520 | {chunk: Operand.t, | |
521 | component: Operand.t}): Operand.t * Statement.t list = | |
522 | let | |
523 | val shift = | |
524 | WordX.fromIntInf (Bits.toIntInf shift, WordSize.shiftArg) | |
525 | val chunkTy = Operand.ty chunk | |
526 | val chunkWidth = Type.width chunkTy | |
527 | val mask = | |
528 | Operand.word | |
529 | (WordX.notb | |
530 | (WordX.lshift | |
531 | (WordX.resize (WordX.allOnes (WordSize.fromBits (Type.width ty)), | |
532 | WordSize.fromBits chunkWidth), | |
533 | shift))) | |
534 | val (s1, chunk) = Statement.andb (chunk, mask) | |
535 | val (component, s2) = Statement.resize (component, chunkTy) | |
536 | val (s3, component) = Statement.lshift (component, Operand.word shift) | |
537 | val (s4, result) = Statement.orb (chunk, component) | |
538 | in | |
539 | (result, [s1] @ s2 @ [s3, s4]) | |
540 | end | |
541 | ||
542 | val update = | |
543 | Trace.trace2 | |
544 | ("PackedRepresentation.Unpack.update", | |
545 | layout, | |
546 | fn {chunk, component} => | |
547 | Layout.record [("chunk", Operand.layout chunk), | |
548 | ("component", Operand.layout component)], | |
549 | Layout.tuple2 (Operand.layout, | |
550 | List.layout Statement.layout)) | |
551 | update | |
552 | end | |
553 | ||
554 | structure Base = | |
555 | struct | |
556 | open Base | |
557 | ||
558 | fun toOperand {base: Operand.t t, | |
559 | eltWidth: Bytes.t option, | |
560 | offset: Bytes.t, | |
561 | ty: Type.t}: Operand.t * Statement.t list = | |
562 | case base of | |
563 | Object base => | |
564 | (Offset {base = base, | |
565 | offset = offset, | |
566 | ty = ty}, | |
567 | []) | |
568 | | VectorSub {index, vector} => | |
569 | let | |
570 | val eltWidth = | |
571 | case eltWidth of | |
572 | NONE => Error.bug "PackedRepresentation.Base.toOperand: eltWidth" | |
573 | | SOME w => w | |
574 | in | |
575 | case Scale.fromBytes eltWidth of | |
576 | NONE => | |
577 | let | |
578 | val seqIndexSize = WordSize.seqIndex () | |
579 | val seqIndexTy = Type.word seqIndexSize | |
580 | val prod = Var.newNoname () | |
581 | val s = | |
582 | PrimApp {args = (Vector.new2 | |
583 | (index, | |
584 | Operand.word | |
585 | (WordX.fromIntInf | |
586 | (Bytes.toIntInf eltWidth, | |
587 | seqIndexSize)))), | |
588 | dst = SOME (prod, seqIndexTy), | |
589 | prim = (Prim.wordMul | |
590 | (seqIndexSize, | |
591 | {signed = false}))} | |
592 | in | |
593 | (ArrayOffset {base = vector, | |
594 | index = Var {var = prod, ty = seqIndexTy}, | |
595 | offset = offset, | |
596 | scale = Scale.One, | |
597 | ty = ty}, | |
598 | [s]) | |
599 | end | |
600 | | SOME s => | |
601 | (ArrayOffset {base = vector, | |
602 | index = index, | |
603 | offset = offset, | |
604 | scale = s, | |
605 | ty = ty}, | |
606 | []) | |
607 | end | |
608 | end | |
609 | ||
610 | structure Select = | |
611 | struct | |
612 | datatype t = | |
613 | None | |
614 | | Direct of {ty: Type.t} | |
615 | | Indirect of {offset: Bytes.t, | |
616 | ty: Type.t} | |
617 | | IndirectUnpack of {offset: Bytes.t, | |
618 | rest: Unpack.t, | |
619 | ty: Type.t} | |
620 | | Unpack of Unpack.t | |
621 | ||
622 | fun layout s = | |
623 | let | |
624 | open Layout | |
625 | in | |
626 | case s of | |
627 | None => str "None" | |
628 | | Direct {ty} => seq [str "Direct ", | |
629 | record [("ty", Type.layout ty)]] | |
630 | | Indirect {offset, ty} => | |
631 | seq [str "Indirect ", | |
632 | record [("offset", Bytes.layout offset), | |
633 | ("ty", Type.layout ty)]] | |
634 | | IndirectUnpack {offset, rest, ty} => | |
635 | seq [str "IndirectUnpack ", | |
636 | record [("offset", Bytes.layout offset), | |
637 | ("rest", Unpack.layout rest), | |
638 | ("ty", Type.layout ty)]] | |
639 | | Unpack u => seq [str "Unpack ", Unpack.layout u] | |
640 | end | |
641 | ||
642 | val lshift: t * Bits.t -> t = | |
643 | fn (s, b) => | |
644 | case s of | |
645 | None => None | |
646 | | Direct {ty} => Unpack (Unpack.T {shift = b, ty = ty}) | |
647 | | Unpack u => Unpack (Unpack.lshift (u, b)) | |
648 | | _ => Error.bug "PackedRepresentation.Select.lshift" | |
649 | ||
650 | fun select (s: t, {base: Operand.t Base.t, | |
651 | dst: Var.t * Type.t, | |
652 | eltWidth: Bytes.t option}): Statement.t list = | |
653 | let | |
654 | fun move (src, ss) = | |
655 | let | |
656 | val (dst, dstTy) = dst | |
657 | val (src, ss') = Statement.resize (src, dstTy) | |
658 | in | |
659 | ss @ ss' @ [Bind {dst = (dst, dstTy), | |
660 | isMutable = false, | |
661 | src = src}] | |
662 | end | |
663 | in | |
664 | case s of | |
665 | None => [] | |
666 | | Direct _ => move (Base.object base, []) | |
667 | | Indirect {offset, ty} => | |
668 | move (Base.toOperand {base = base, | |
669 | eltWidth = eltWidth, | |
670 | offset = offset, | |
671 | ty = ty}) | |
672 | | IndirectUnpack {offset, rest, ty} => | |
673 | let | |
674 | val tmpVar = Var.newNoname () | |
675 | val tmpOp = Var {ty = ty, var = tmpVar} | |
676 | val (src, ss) = | |
677 | Base.toOperand {base = base, | |
678 | eltWidth = eltWidth, | |
679 | offset = offset, | |
680 | ty = ty} | |
681 | in | |
682 | ss @ (Bind {dst = (tmpVar, ty), | |
683 | isMutable = false, | |
684 | src = src} | |
685 | :: Unpack.select (rest, {dst = dst, src = tmpOp})) | |
686 | end | |
687 | | Unpack u => | |
688 | Unpack.select (u, {dst = dst, src = Base.object base}) | |
689 | end | |
690 | ||
691 | val select = | |
692 | Trace.trace | |
693 | ("PackedRepresentation.Select.select", | |
694 | layout o #1, List.layout Statement.layout) | |
695 | select | |
696 | ||
697 | fun update (s: t, {base: Operand.t Base.t, | |
698 | eltWidth: Bytes.t option, | |
699 | value: Operand.t}): Statement.t list = | |
700 | case s of | |
701 | Indirect {offset, ty} => | |
702 | let | |
703 | val (dst, ss) = | |
704 | Base.toOperand {base = base, | |
705 | eltWidth = eltWidth, | |
706 | offset = offset, | |
707 | ty = ty} | |
708 | in | |
709 | ss @ [Move {dst = dst, src = value}] | |
710 | end | |
711 | | IndirectUnpack {offset, rest, ty} => | |
712 | let | |
713 | val (chunk, ss) = | |
714 | Base.toOperand {base = base, | |
715 | eltWidth = eltWidth, | |
716 | offset = offset, | |
717 | ty = ty} | |
718 | val (newChunk, ss') = | |
719 | Unpack.update (rest, {chunk = chunk, | |
720 | component = value}) | |
721 | in | |
722 | ss @ ss' @ [Move {dst = chunk, src = newChunk}] | |
723 | end | |
724 | | _ => Error.bug "PackedRepresentation.Select.update: non-indirect" | |
725 | ||
726 | val update = | |
727 | Trace.trace | |
728 | ("PackedRepresentation.Select.update", | |
729 | layout o #1, List.layout Statement.layout) | |
730 | update | |
731 | end | |
732 | ||
733 | structure Selects = | |
734 | struct | |
735 | datatype t = T of {orig: S.Type.t, | |
736 | select: Select.t} vector | |
737 | ||
738 | fun layout (T v) = Vector.layout (Select.layout o #select) v | |
739 | ||
740 | val empty = T (Vector.new0 ()) | |
741 | ||
742 | fun map (T v, f) = | |
743 | T (Vector.map (v, fn {orig, select} => | |
744 | {orig = orig, | |
745 | select = f select})) | |
746 | ||
747 | fun select (T v, {base: Operand.t Base.t, | |
748 | dst: Var.t * Type.t, | |
749 | eltWidth: Bytes.t option, | |
750 | offset: int}): Statement.t list = | |
751 | Select.select (#select (Vector.sub (v, offset)), | |
752 | {base = base, eltWidth = eltWidth, dst = dst}) | |
753 | ||
754 | fun update (T v, {base, eltWidth, offset, value}) = | |
755 | Select.update (#select (Vector.sub (v, offset)), | |
756 | {base = base, eltWidth = eltWidth, value = value}) | |
757 | ||
758 | fun lshift (T v, b: Bits.t) = | |
759 | T (Vector.map (v, fn {orig, select} => | |
760 | {orig = orig, | |
761 | select = Select.lshift (select, b)})) | |
762 | end | |
763 | ||
764 | structure ObjptrRep = | |
765 | struct | |
766 | datatype t = T of {components: {component: Component.t, | |
767 | offset: Bytes.t} vector, | |
768 | componentsTy: Type.t, | |
769 | selects: Selects.t, | |
770 | ty: Type.t, | |
771 | tycon: ObjptrTycon.t} | |
772 | ||
773 | fun layout (T {components, componentsTy, selects, ty, tycon}) = | |
774 | let | |
775 | open Layout | |
776 | in | |
777 | record | |
778 | [("components", | |
779 | Vector.layout (fn {component, offset} => | |
780 | record [("component", Component.layout component), | |
781 | ("offset", Bytes.layout offset)]) | |
782 | components), | |
783 | ("componentsTy", Type.layout componentsTy), | |
784 | ("selects", Selects.layout selects), | |
785 | ("ty", Type.layout ty), | |
786 | ("tycon", ObjptrTycon.layout tycon)] | |
787 | end | |
788 | ||
789 | local | |
790 | fun make f (T r) = f r | |
791 | in | |
792 | val componentsTy = make #componentsTy | |
793 | val ty = make #ty | |
794 | end | |
795 | ||
796 | fun equals (T {tycon = c, ...}, T {tycon = c', ...}) = | |
797 | ObjptrTycon.equals (c, c') | |
798 | ||
799 | fun rep (T {ty, ...}) = | |
800 | Rep.T {rep = Rep.Objptr {endsIn00 = true}, | |
801 | ty = ty} | |
802 | ||
803 | fun make {components, isVector, selects, tycon} = | |
804 | let | |
805 | val width = | |
806 | Vector.fold | |
807 | (components, Bytes.zero, fn ({component = c, ...}, ac) => | |
808 | Bytes.+ (ac, Type.bytes (Component.ty c))) | |
809 | val padBytes: Bytes.t = | |
810 | if isVector | |
811 | then let | |
812 | val alignWidth = | |
813 | case !Control.align of | |
814 | Control.Align4 => width | |
815 | | Control.Align8 => | |
816 | if (Vector.exists | |
817 | (components, fn {component = c, ...} => | |
818 | (case Type.deReal (Component.ty c) of | |
819 | NONE => false | |
820 | | SOME s => | |
821 | RealSize.equals (s, RealSize.R64)) | |
822 | orelse | |
823 | (case Type.deWord (Component.ty c) of | |
824 | NONE => false | |
825 | | SOME s => | |
826 | WordSize.equals (s, WordSize.word64)) | |
827 | orelse | |
828 | (Type.isObjptr (Component.ty c) | |
829 | andalso WordSize.equals (WordSize.objptr (), | |
830 | WordSize.word64)))) | |
831 | then Bytes.alignWord64 width | |
832 | else width | |
833 | in | |
834 | Bytes.- (alignWidth, width) | |
835 | end | |
836 | else let | |
837 | (* Note that with Align8 and objptrSize == 64bits, | |
838 | * the following ensures that objptrs will be | |
839 | * mod 8 aligned. | |
840 | *) | |
841 | val width' = Bytes.+ (width, Runtime.normalMetaDataSize ()) | |
842 | val alignWidth' = | |
843 | case !Control.align of | |
844 | Control.Align4 => Bytes.alignWord32 width' | |
845 | | Control.Align8 => Bytes.alignWord64 width' | |
846 | val alignWidth = Bytes.- (alignWidth', Runtime.normalMetaDataSize ()) | |
847 | in | |
848 | Bytes.- (alignWidth, width) | |
849 | end | |
850 | val (components, selects) = | |
851 | if Bytes.isZero padBytes | |
852 | then (components, selects) | |
853 | else | |
854 | (* Need to insert a pad before the first objptr. *) | |
855 | let | |
856 | val {no = nonObjptrs, yes = objptrs} = | |
857 | Vector.partition | |
858 | (components, fn {component = c, ...} => | |
859 | Rep.isObjptr (Component.rep c)) | |
860 | val padOffset = | |
861 | if Vector.isEmpty objptrs | |
862 | then width | |
863 | else #offset (Vector.first objptrs) | |
864 | val pad = | |
865 | (#1 o Vector.unfoldi) | |
866 | ((Bytes.toInt padBytes) div (Bytes.toInt Bytes.inWord32), | |
867 | padOffset, | |
868 | fn (_, padOffset) => | |
869 | ({component = (Component.padToWidth | |
870 | (Component.unit, Bits.inWord32)), | |
871 | offset = padOffset}, | |
872 | Bytes.+ (padOffset, Bytes.inWord32))) | |
873 | val objptrs = | |
874 | Vector.map (objptrs, fn {component = c, offset} => | |
875 | {component = c, | |
876 | offset = Bytes.+ (offset, padBytes)}) | |
877 | val components = | |
878 | Vector.concat [nonObjptrs, pad, objptrs] | |
879 | val selects = | |
880 | Selects.map | |
881 | (selects, fn s => | |
882 | case s of | |
883 | Select.Indirect {offset, ty} => | |
884 | if Bytes.>= (offset, padOffset) | |
885 | then | |
886 | Select.Indirect | |
887 | {offset = Bytes.+ (offset, padBytes), | |
888 | ty = ty} | |
889 | else s | |
890 | | _ => s) | |
891 | in | |
892 | (components, selects) | |
893 | end | |
894 | val componentsTy = | |
895 | Type.seq (Vector.map (components, Component.ty o #component)) | |
896 | in | |
897 | T {components = components, | |
898 | componentsTy = componentsTy, | |
899 | selects = selects, | |
900 | ty = Type.objptr tycon, | |
901 | tycon = tycon} | |
902 | end | |
903 | ||
904 | val make = | |
905 | let | |
906 | open Layout | |
907 | in | |
908 | Trace.trace | |
909 | ("PackedRepresentation.ObjptrRep.make", | |
910 | fn {components, isVector, selects, tycon} => | |
911 | record | |
912 | [("components", | |
913 | Vector.layout (fn {component, offset} => | |
914 | record [("component", Component.layout component), | |
915 | ("offset", Bytes.layout offset)]) | |
916 | components), | |
917 | ("isVector", Bool.layout isVector), | |
918 | ("selects", Selects.layout selects), | |
919 | ("tycon", ObjptrTycon.layout tycon)], | |
920 | layout) | |
921 | end | |
922 | make | |
923 | ||
924 | fun box (component: Component.t, opt: ObjptrTycon.t, selects: Selects.t) = | |
925 | let | |
926 | val selects = | |
927 | Selects.map | |
928 | (selects, fn s => | |
929 | let | |
930 | datatype z = datatype Select.t | |
931 | in | |
932 | case s of | |
933 | None => None | |
934 | | Direct {ty} => Indirect {offset = Bytes.zero, ty = ty} | |
935 | | Unpack u => IndirectUnpack {offset = Bytes.zero, | |
936 | rest = u, | |
937 | ty = Component.ty component} | |
938 | | _ => Error.bug "PackedRepresentation.ObjptrRep.box: cannot lift selects" | |
939 | end) | |
940 | in | |
941 | make {components = Vector.new1 {component = component, | |
942 | offset = Bytes.zero}, | |
943 | isVector = false, | |
944 | selects = selects, | |
945 | tycon = opt} | |
946 | end | |
947 | ||
948 | fun tuple (T {components, componentsTy, ty, tycon, ...}, | |
949 | {dst = dst: Var.t, | |
950 | src: {index: int} -> Operand.t}) = | |
951 | let | |
952 | val object = Var {ty = ty, var = dst} | |
953 | val stores = | |
954 | Vector.foldr | |
955 | (components, [], fn ({component, offset}, ac) => | |
956 | let | |
957 | val tmpVar = Var.newNoname () | |
958 | val tmpTy = Component.ty component | |
959 | val statements = | |
960 | Component.tuple (component, | |
961 | {dst = (tmpVar, tmpTy), src = src}) | |
962 | in | |
963 | if List.isEmpty statements | |
964 | then ac | |
965 | else statements | |
966 | @ (Move {dst = Offset {base = object, | |
967 | offset = offset, | |
968 | ty = tmpTy}, | |
969 | src = Var {ty = tmpTy, var = tmpVar}} | |
970 | :: ac) | |
971 | end) | |
972 | in | |
973 | Object {dst = (dst, ty), | |
974 | header = Runtime.typeIndexToHeader (ObjptrTycon.index tycon), | |
975 | size = Bytes.+ (Type.bytes componentsTy, Runtime.normalMetaDataSize ())} | |
976 | :: stores | |
977 | end | |
978 | ||
979 | val tuple = | |
980 | Trace.trace2 | |
981 | ("PackedRepresentation.ObjptrRep.tuple", | |
982 | layout, Var.layout o #dst, List.layout Statement.layout) | |
983 | tuple | |
984 | end | |
985 | ||
986 | structure TupleRep = | |
987 | struct | |
988 | datatype t = | |
989 | Direct of {component: Component.t, | |
990 | selects: Selects.t} | |
991 | | Indirect of ObjptrRep.t | |
992 | ||
993 | fun layout tr = | |
994 | let | |
995 | open Layout | |
996 | in | |
997 | case tr of | |
998 | Direct {component, selects} => | |
999 | seq [str "Direct ", | |
1000 | record [("component", Component.layout component), | |
1001 | ("selects", Selects.layout selects)]] | |
1002 | | Indirect pr => | |
1003 | seq [str "Indirect ", ObjptrRep.layout pr] | |
1004 | end | |
1005 | ||
1006 | val unit = Direct {component = Component.unit, | |
1007 | selects = Selects.empty} | |
1008 | ||
1009 | val equals: t * t -> bool = | |
1010 | fn z => | |
1011 | case z of | |
1012 | (Direct {component = c, ...}, Direct {component = c', ...}) => | |
1013 | Component.equals (c, c') | |
1014 | | (Indirect pr, Indirect pr') => ObjptrRep.equals (pr, pr') | |
1015 | | _ => false | |
1016 | ||
1017 | fun rep (tr: t): Rep.t = | |
1018 | case tr of | |
1019 | Direct {component, ...} => Component.rep component | |
1020 | | Indirect p => ObjptrRep.rep p | |
1021 | ||
1022 | val ty = Rep.ty o rep | |
1023 | ||
1024 | fun selects (tr: t): Selects.t = | |
1025 | case tr of | |
1026 | Direct {selects, ...} => selects | |
1027 | | Indirect (ObjptrRep.T {selects, ...}) => selects | |
1028 | ||
1029 | fun tuple (tr: t, | |
1030 | {dst: Var.t * Type.t, | |
1031 | src: {index: int} -> Operand.t}): Statement.t list = | |
1032 | case tr of | |
1033 | Direct {component = c, ...} => | |
1034 | Component.tuple (c, {dst = dst, src = src}) | |
1035 | | Indirect pr => | |
1036 | ObjptrRep.tuple (pr, {dst = #1 dst, src = src}) | |
1037 | ||
1038 | val tuple = | |
1039 | Trace.trace2 | |
1040 | ("PackedRepresentation.TupleRep.tuple", | |
1041 | layout, Var.layout o #1 o #dst, List.layout Statement.layout) | |
1042 | tuple | |
1043 | ||
1044 | (* TupleRep.make decides how to layout a sequence of types in an object, | |
1045 | * or in the case of a vector, in a vector element. | |
1046 | * Vectors are treated slightly specially because we don't require element | |
1047 | * widths to be a multiple of the word32 size. | |
1048 | * At the front of the object, we place all the word64s, followed by | |
1049 | * all the word32s. Then, we pack in all the types that are smaller than a | |
1050 | * word32. This is done by packing in a sequence of words, greedily, | |
1051 | * starting with the largest type and moving to the smallest. We pad to | |
1052 | * ensure that a value never crosses a word32 boundary. Finally, if there | |
1053 | * are any objptrs, they go at the end of the object. | |
1054 | * | |
1055 | * There is some extra logic here to specially represent (boxed) | |
1056 | * tuples that are entirely comprised of primitive types. The | |
1057 | * primary motivation is that "word8 ref" and "word16 ref" are | |
1058 | * FFI types, and must have representations that are compatible | |
1059 | * with C. In particular, on a big-endian platform, such | |
1060 | * sub-word32 components must be at the low byte offset (but | |
1061 | * high bit offset) of the containing word32. | |
1062 | *) | |
1063 | fun make (objptrTycon: ObjptrTycon.t, | |
1064 | rs: {isMutable: bool, | |
1065 | rep: Rep.t, | |
1066 | ty: S.Type.t} vector, | |
1067 | {forceBox: bool, | |
1068 | isVector: bool}): t = | |
1069 | let | |
1070 | val objptrs = ref [] | |
1071 | val numObjptrs = ref 0 | |
1072 | val word64s = ref [] | |
1073 | val numWord64s = ref 0 | |
1074 | val word32s = ref [] | |
1075 | val numWord32s = ref 0 | |
1076 | val subword32s = Array.array (Bits.toInt Bits.inWord32, []) | |
1077 | val widthSubword32s = ref 0 | |
1078 | val hasNonPrim = ref false | |
1079 | val () = | |
1080 | Vector.foreachi | |
1081 | (rs, fn (i, {rep, ...}) => | |
1082 | let | |
1083 | fun addDirect (l, n) = | |
1084 | (List.push (l, {component = Component.Direct {index = i, | |
1085 | rep = rep}, | |
1086 | index = i}) | |
1087 | ; Int.inc n) | |
1088 | fun addSubword32 b = | |
1089 | (Array.update | |
1090 | (subword32s, b, | |
1091 | {index = i, rep = rep} :: Array.sub (subword32s, b)) | |
1092 | ; widthSubword32s := !widthSubword32s + b) | |
1093 | in | |
1094 | case Rep.rep rep of | |
1095 | Rep.NonObjptr => | |
1096 | let | |
1097 | val b = Bits.toInt (Rep.width rep) | |
1098 | in | |
1099 | case b of | |
1100 | 0 => () | |
1101 | | 8 => addSubword32 b | |
1102 | | 16 => addSubword32 b | |
1103 | | 32 => addDirect (word32s, numWord32s) | |
1104 | | 64 => addDirect (word64s, numWord64s) | |
1105 | | _ => (addSubword32 b | |
1106 | ; hasNonPrim := true) | |
1107 | end | |
1108 | | Rep.Objptr _ => addDirect (objptrs, numObjptrs) | |
1109 | end) | |
1110 | val selects = Array.array (Vector.length rs, Select.None) | |
1111 | val hasNonPrim = !hasNonPrim | |
1112 | val numComponents = | |
1113 | !numObjptrs + !numWord64s + !numWord32s + | |
1114 | (let | |
1115 | val widthSubword32s = !widthSubword32s | |
1116 | in | |
1117 | Int.quot (widthSubword32s, 32) | |
1118 | + Int.min (1, Int.rem (widthSubword32s, 32)) | |
1119 | end) | |
1120 | val needsBox = | |
1121 | forceBox | |
1122 | orelse Vector.exists (rs, #isMutable) | |
1123 | orelse numComponents > 1 | |
1124 | val padToPrim = isVector andalso 1 = numComponents | |
1125 | val isBigEndian = Control.Target.bigEndian () | |
1126 | fun byteShiftToByteOffset (compSz: Bytes.t, tySz: Bytes.t, shift: Bytes.t) = | |
1127 | if not isBigEndian | |
1128 | then shift | |
1129 | else Bytes.- (compSz, Bytes.+ (tySz, shift)) | |
1130 | fun simple (l, tyWidth: Bytes.t, offset: Bytes.t, components) = | |
1131 | List.fold | |
1132 | (l, (offset, components), | |
1133 | fn ({component, index}, (offset, ac)) => | |
1134 | (Bytes.+ (offset, tyWidth), | |
1135 | let | |
1136 | val ty = Component.ty component | |
1137 | val () = | |
1138 | Array.update | |
1139 | (selects, index, | |
1140 | if needsBox | |
1141 | then Select.Indirect {offset = offset, ty = ty} | |
1142 | else Select.Direct {ty = ty}) | |
1143 | in | |
1144 | {component = component, | |
1145 | offset = offset} :: ac | |
1146 | end)) | |
1147 | val offset = Bytes.zero | |
1148 | val components = [] | |
1149 | val (offset, components) = | |
1150 | simple (!word64s, Bytes.inWord64, offset, components) | |
1151 | val (offset, components) = | |
1152 | simple (!word32s, Bytes.inWord32, offset, components) | |
1153 | (* j is the maximum index <= remainingWidth at which an | |
1154 | * element of subword32s may be nonempty. | |
1155 | *) | |
1156 | fun getSubword32Components (j: int, | |
1157 | remainingWidth: Bits.t, | |
1158 | components) = | |
1159 | if 0 = j | |
1160 | then Vector.fromListRev components | |
1161 | else | |
1162 | let | |
1163 | val elts = Array.sub (subword32s, j) | |
1164 | in | |
1165 | case elts of | |
1166 | [] => getSubword32Components (j - 1, remainingWidth, components) | |
1167 | | {index, rep} :: elts => | |
1168 | let | |
1169 | val () = Array.update (subword32s, j, elts) | |
1170 | val remainingWidth = Bits.- (remainingWidth, Rep.width rep) | |
1171 | in | |
1172 | getSubword32Components | |
1173 | (Bits.toInt remainingWidth, | |
1174 | remainingWidth, | |
1175 | {index = index, rep = rep} :: components) | |
1176 | end | |
1177 | end | |
1178 | (* max is the maximum index at which an element of | |
1179 | * subword32s may be nonempty. | |
1180 | *) | |
1181 | fun makeSubword32s (max: int, offset: Bytes.t, ac) = | |
1182 | if 0 = max | |
1183 | then (offset, ac) | |
1184 | else | |
1185 | if List.isEmpty (Array.sub (subword32s, max)) | |
1186 | then makeSubword32s (max - 1, offset, ac) | |
1187 | else | |
1188 | let | |
1189 | val components = | |
1190 | getSubword32Components (max, Bits.inWord32, []) | |
1191 | val componentTy = | |
1192 | Type.seq (Vector.map (components, Rep.ty o #rep)) | |
1193 | val component = | |
1194 | (Component.Word o WordRep.T) | |
1195 | {components = components, | |
1196 | rep = Rep.T {rep = Rep.NonObjptr, | |
1197 | ty = componentTy}} | |
1198 | val (component, componentTy) = | |
1199 | if needsBox | |
1200 | then if padToPrim | |
1201 | then (Component.padToPrim component, | |
1202 | Type.padToPrim componentTy) | |
1203 | else (Component.padToWidth (component, Bits.inWord32), | |
1204 | Type.padToWidth (componentTy, Bits.inWord32)) | |
1205 | else (component, componentTy) | |
1206 | val _ = | |
1207 | Vector.fold | |
1208 | (components, Bits.zero, | |
1209 | fn ({index, rep}, shift) => | |
1210 | let | |
1211 | val repTy = Rep.ty rep | |
1212 | val repTyWidth = Type.width repTy | |
1213 | val repWidth = Rep.width rep | |
1214 | val unpack = Unpack.T {shift = shift, | |
1215 | ty = repTy} | |
1216 | fun getByteOffset () = | |
1217 | Bytes.+ | |
1218 | (offset, | |
1219 | byteShiftToByteOffset | |
1220 | (Type.bytes componentTy, | |
1221 | Bits.toBytes repTyWidth, | |
1222 | Bits.toBytes shift)) | |
1223 | val select = | |
1224 | if needsBox | |
1225 | then if ((Bits.isWord8Aligned shift | |
1226 | andalso (Bits.equals | |
1227 | (repTyWidth, | |
1228 | Bits.inWord8))) | |
1229 | orelse | |
1230 | (Bits.isWord16Aligned shift | |
1231 | andalso (Bits.equals | |
1232 | (repTyWidth, | |
1233 | Bits.inWord16)))) | |
1234 | then (Select.Indirect | |
1235 | {offset = getByteOffset (), | |
1236 | ty = repTy}) | |
1237 | else (Select.IndirectUnpack | |
1238 | {offset = offset, | |
1239 | rest = unpack, | |
1240 | ty = componentTy}) | |
1241 | else Select.Unpack unpack | |
1242 | val () = | |
1243 | Array.update | |
1244 | (selects, index, select) | |
1245 | in | |
1246 | Bits.+ (shift, repWidth) | |
1247 | end) | |
1248 | val ac = {component = component, | |
1249 | offset = offset} :: ac | |
1250 | in | |
1251 | makeSubword32s | |
1252 | (max, | |
1253 | (* Either the width of the word rep component | |
1254 | * is 32 bits, or this is the only | |
1255 | * component, so offset doesn't matter. | |
1256 | *) | |
1257 | Bytes.+ (offset, Bytes.inWord32), | |
1258 | ac) | |
1259 | end | |
1260 | fun makeSubword32sAllPrims (max: int, offset: Bytes.t, ac) = | |
1261 | (* hasNonPrim = false, needsBox = true *) | |
1262 | if 0 = max | |
1263 | then (offset, ac) | |
1264 | else | |
1265 | if List.isEmpty (Array.sub (subword32s, max)) | |
1266 | then makeSubword32sAllPrims (max - 1, offset, ac) | |
1267 | else | |
1268 | let | |
1269 | val origComponents = | |
1270 | getSubword32Components (max, Bits.inWord32, []) | |
1271 | val components = | |
1272 | if isBigEndian | |
1273 | then Vector.rev origComponents | |
1274 | else origComponents | |
1275 | val componentTy = | |
1276 | Type.seq (Vector.map (components, Rep.ty o #rep)) | |
1277 | val component = | |
1278 | (Component.Word o WordRep.T) | |
1279 | {components = components, | |
1280 | rep = Rep.T {rep = Rep.NonObjptr, | |
1281 | ty = componentTy}} | |
1282 | val component = | |
1283 | if padToPrim | |
1284 | then if isBigEndian | |
1285 | then Component.padToPrimLow component | |
1286 | else Component.padToPrim component | |
1287 | else if isBigEndian | |
1288 | then Component.padToWidthLow (component, Bits.inWord32) | |
1289 | else Component.padToWidth (component, Bits.inWord32) | |
1290 | val _ = | |
1291 | Vector.fold | |
1292 | (origComponents, offset, | |
1293 | fn ({index, rep}, offset) => | |
1294 | let | |
1295 | val () = | |
1296 | Array.update | |
1297 | (selects, index, | |
1298 | Select.Indirect | |
1299 | {offset = offset, | |
1300 | ty = Rep.ty rep}) | |
1301 | in | |
1302 | Bytes.+ (offset, Bits.toBytes (Rep.width rep)) | |
1303 | end) | |
1304 | val ac = {component = component, | |
1305 | offset = offset} :: ac | |
1306 | in | |
1307 | makeSubword32sAllPrims | |
1308 | (max, | |
1309 | (* Either the width of the word rep component | |
1310 | * is 32 bits, or this is the only | |
1311 | * component, so offset doesn't matter. | |
1312 | *) | |
1313 | Bytes.+ (offset, Bytes.inWord32), | |
1314 | ac) | |
1315 | end | |
1316 | val (offset, components) = | |
1317 | if (not hasNonPrim) andalso needsBox | |
1318 | then makeSubword32sAllPrims (Array.length subword32s - 1, offset, components) | |
1319 | else makeSubword32s (Array.length subword32s - 1, offset, components) | |
1320 | val (_, components) = | |
1321 | simple (!objptrs, Runtime.objptrSize (), offset, components) | |
1322 | val components = Vector.fromListRev components | |
1323 | (* | |
1324 | val () = | |
1325 | Assert.assert | |
1326 | ("PackedRepresentation.TupleRep.make", fn () => | |
1327 | numComponents = Vector.length components) | |
1328 | *) | |
1329 | val getSelects = | |
1330 | Selects.T (Vector.tabulate | |
1331 | (Array.length selects, fn i => | |
1332 | {orig = #ty (Vector.sub (rs, i)), | |
1333 | select = Array.sub (selects, i)})) | |
1334 | in | |
1335 | if needsBox | |
1336 | then Indirect (ObjptrRep.make {components = components, | |
1337 | isVector = isVector, | |
1338 | selects = getSelects, | |
1339 | tycon = objptrTycon}) | |
1340 | else if numComponents = 0 | |
1341 | then unit | |
1342 | else Direct {component = #component (Vector.first components), | |
1343 | selects = getSelects} | |
1344 | end | |
1345 | val make = | |
1346 | Trace.trace3 | |
1347 | ("PackedRepresentation.TupleRep.make", | |
1348 | ObjptrTycon.layout, | |
1349 | Vector.layout (fn {isMutable, rep, ty} => | |
1350 | Layout.record [("isMutable", Bool.layout isMutable), | |
1351 | ("rep", Rep.layout rep), | |
1352 | ("ty", S.Type.layout ty)]), | |
1353 | fn {forceBox, isVector} => | |
1354 | Layout.record [("forceBox", Bool.layout forceBox), | |
1355 | ("isVector", Bool.layout isVector)], | |
1356 | ||
1357 | layout) | |
1358 | make | |
1359 | end | |
1360 | ||
1361 | structure ConRep = | |
1362 | struct | |
1363 | datatype t = | |
1364 | ShiftAndTag of {component: Component.t, | |
1365 | selects: Selects.t, | |
1366 | tag: WordX.t, | |
1367 | ty: Type.t (* alread padded to prim *)} | |
1368 | | Tag of {tag: WordX.t, | |
1369 | ty: Type.t} | |
1370 | | Tuple of TupleRep.t | |
1371 | ||
1372 | val layout = | |
1373 | let | |
1374 | open Layout | |
1375 | in | |
1376 | fn ShiftAndTag {component, selects, tag, ty} => | |
1377 | seq [str "ShiftAndTag ", | |
1378 | record [("component", Component.layout component), | |
1379 | ("selects", Selects.layout selects), | |
1380 | ("tag", WordX.layout tag), | |
1381 | ("ty", Type.layout ty)]] | |
1382 | | Tag {tag, ...} => seq [str "Tag ", WordX.layout tag] | |
1383 | | Tuple tr => TupleRep.layout tr | |
1384 | end | |
1385 | ||
1386 | val equals: t * t -> bool = | |
1387 | fn (ShiftAndTag {component = c1, tag = t1, ...}, | |
1388 | ShiftAndTag {component = c2, tag = t2, ...}) => | |
1389 | Component.equals (c1, c2) andalso WordX.equals (t1, t2) | |
1390 | | (Tag {tag = t1, ty = ty1}, Tag {tag = t2, ty = ty2}) => | |
1391 | WordX.equals (t1, t2) andalso Type.equals (ty1, ty2) | |
1392 | | (Tuple tr1, Tuple tr2) => TupleRep.equals (tr1, tr2) | |
1393 | | _ => false | |
1394 | ||
1395 | val rep: t -> Rep.t = | |
1396 | fn ShiftAndTag {ty, ...} => Rep.nonObjptr ty | |
1397 | | Tag {ty, ...} => Rep.nonObjptr ty | |
1398 | | Tuple tr => TupleRep.rep tr | |
1399 | ||
1400 | val box = Tuple o TupleRep.Indirect | |
1401 | ||
1402 | local | |
1403 | fun make i = | |
1404 | let | |
1405 | val tag = WordX.fromIntInf (i, WordSize.bool) | |
1406 | in | |
1407 | Tag {tag = tag, ty = Type.ofWordX tag} | |
1408 | end | |
1409 | in | |
1410 | val falsee = make 0 | |
1411 | val truee = make 1 | |
1412 | end | |
1413 | ||
1414 | val unit = Tuple TupleRep.unit | |
1415 | ||
1416 | fun conApp (r: t, {dst: Var.t * Type.t, | |
1417 | src: {index: int} -> Operand.t}): Statement.t list = | |
1418 | case r of | |
1419 | ShiftAndTag {component, tag, ...} => | |
1420 | let | |
1421 | val (dstVar, dstTy) = dst | |
1422 | val shift = Operand.word (WordX.fromIntInf | |
1423 | (Bits.toIntInf | |
1424 | (WordSize.bits | |
1425 | (WordX.size tag)), | |
1426 | WordSize.shiftArg)) | |
1427 | val tmpVar = Var.newNoname () | |
1428 | val tmpTy = | |
1429 | Type.padToWidth (Component.ty component, Type.width dstTy) | |
1430 | val tmp = Var {ty = tmpTy, var = tmpVar} | |
1431 | val component = | |
1432 | Component.tuple (component, {dst = (tmpVar, tmpTy), | |
1433 | src = src}) | |
1434 | val (s1, tmp) = Statement.lshift (tmp, shift) | |
1435 | val mask = Operand.word (WordX.resize | |
1436 | (tag, | |
1437 | WordSize.fromBits | |
1438 | (Type.width | |
1439 | (Operand.ty tmp)))) | |
1440 | val (s2, tmp) = Statement.orb (tmp, mask) | |
1441 | val s3 = Bind {dst = (dstVar, dstTy), | |
1442 | isMutable = false, | |
1443 | src = tmp} | |
1444 | in | |
1445 | component @ [s1, s2, s3] | |
1446 | end | |
1447 | | Tag {tag, ...} => | |
1448 | let | |
1449 | val (dstVar, dstTy) = dst | |
1450 | val src = Operand.word (WordX.resize | |
1451 | (tag, | |
1452 | WordSize.fromBits | |
1453 | (Type.width dstTy))) | |
1454 | in | |
1455 | [Bind {dst = (dstVar, dstTy), | |
1456 | isMutable = false, | |
1457 | src = src}] | |
1458 | end | |
1459 | | Tuple tr => TupleRep.tuple (tr, {dst = dst, src = src}) | |
1460 | ||
1461 | val conApp = | |
1462 | Trace.trace | |
1463 | ("PackedRepresentation.ConRep.conApp", | |
1464 | layout o #1, List.layout Statement.layout) | |
1465 | conApp | |
1466 | end | |
1467 | ||
1468 | structure Block = | |
1469 | struct | |
1470 | open Block | |
1471 | ||
1472 | val extra: t list ref = ref [] | |
1473 | ||
1474 | fun getExtra () = !extra before extra := [] | |
1475 | ||
1476 | fun new {statements: Statement.t vector, | |
1477 | transfer: Transfer.t}: Label.t = | |
1478 | let | |
1479 | val l = Label.newNoname () | |
1480 | val _ = List.push (extra, | |
1481 | Block.T {args = Vector.new0 (), | |
1482 | kind = Kind.Jump, | |
1483 | label = l, | |
1484 | statements = statements, | |
1485 | transfer = transfer}) | |
1486 | in | |
1487 | l | |
1488 | end | |
1489 | end | |
1490 | ||
1491 | structure Cases = | |
1492 | struct | |
1493 | type t = {con: Con.t, dst: Label.t, dstHasArg: bool} vector | |
1494 | ||
1495 | fun layout (v: t): Layout.t = | |
1496 | Vector.layout | |
1497 | (fn {con, dst, dstHasArg} => | |
1498 | Layout.record [("con", Con.layout con), | |
1499 | ("dst", Label.layout dst), | |
1500 | ("dstHasArg", Bool.layout dstHasArg)]) | |
1501 | v | |
1502 | end | |
1503 | ||
1504 | structure Objptrs = | |
1505 | struct | |
1506 | (* 1 < Vector.length variants *) | |
1507 | datatype t = T of {rep: Rep.t, | |
1508 | variants: {con: Con.t, | |
1509 | objptr: ObjptrRep.t} vector} | |
1510 | ||
1511 | fun layout (T {rep, variants}) = | |
1512 | let | |
1513 | open Layout | |
1514 | in | |
1515 | record [("rep", Rep.layout rep), | |
1516 | ("variants", | |
1517 | Vector.layout | |
1518 | (fn {con, objptr} => | |
1519 | record [("con", Con.layout con), | |
1520 | ("objptr", ObjptrRep.layout objptr)]) | |
1521 | variants)] | |
1522 | end | |
1523 | ||
1524 | local | |
1525 | fun make f (T r) = f r | |
1526 | in | |
1527 | val rep = make #rep | |
1528 | end | |
1529 | ||
1530 | val ty = Rep.ty o rep | |
1531 | ||
1532 | fun make {rep, variants}: t = | |
1533 | T {rep = rep, | |
1534 | variants = variants} | |
1535 | ||
1536 | fun genCase (T {variants, ...}, | |
1537 | {cases: Cases.t, | |
1538 | conRep: Con.t -> ConRep.t, | |
1539 | default: Label.t option, | |
1540 | test: Operand.t}) | |
1541 | : Statement.t list * Transfer.t = | |
1542 | let | |
1543 | val cases = | |
1544 | Vector.keepAllMap | |
1545 | (cases, fn {con, dst, dstHasArg} => | |
1546 | case conRep con of | |
1547 | ConRep.Tuple (TupleRep.Indirect (ObjptrRep.T {ty, tycon, ...})) => | |
1548 | SOME (WordX.fromIntInf (Int.toIntInf (ObjptrTycon.index tycon), | |
1549 | WordSize.objptrHeader ()), | |
1550 | Block.new | |
1551 | {statements = Vector.new0 (), | |
1552 | transfer = Goto {args = if dstHasArg | |
1553 | then (Vector.new1 | |
1554 | (Operand.cast (test, ty))) | |
1555 | else Vector.new0 (), | |
1556 | dst = dst}}) | |
1557 | | _ => NONE) | |
1558 | val default = | |
1559 | if Vector.length variants = Vector.length cases | |
1560 | then NONE | |
1561 | else default | |
1562 | val cases = | |
1563 | QuickSort.sortVector (cases, fn ((w, _), (w', _)) => | |
1564 | WordX.le (w, w', {signed = false})) | |
1565 | val shift = Operand.word (WordX.one WordSize.shiftArg) | |
1566 | val (s, tag) = | |
1567 | Statement.rshift (Offset {base = test, | |
1568 | offset = Runtime.headerOffset (), | |
1569 | ty = Type.objptrHeader ()}, | |
1570 | shift) | |
1571 | in | |
1572 | ([s], Switch (Switch.T {cases = cases, | |
1573 | default = default, | |
1574 | size = WordSize.objptrHeader (), | |
1575 | test = tag})) | |
1576 | end | |
1577 | end | |
1578 | ||
1579 | structure Small = | |
1580 | struct | |
1581 | datatype t = T of {isEnum: bool, | |
1582 | rep: Rep.t, | |
1583 | tagBits: Bits.t, | |
1584 | variants: Con.t vector} | |
1585 | ||
1586 | fun layout (T {isEnum, rep, tagBits, variants}) = | |
1587 | let | |
1588 | open Layout | |
1589 | in | |
1590 | record [("isEnum", Bool.layout isEnum), | |
1591 | ("rep", Rep.layout rep), | |
1592 | ("tagBits", Bits.layout tagBits), | |
1593 | ("variants", Vector.layout Con.layout variants)] | |
1594 | end | |
1595 | ||
1596 | local | |
1597 | fun make f (T r) = f r | |
1598 | in | |
1599 | val rep = make #rep | |
1600 | end | |
1601 | ||
1602 | val bool = | |
1603 | T {isEnum = true, | |
1604 | rep = Rep.bool, | |
1605 | tagBits = Bits.one, | |
1606 | variants = Vector.new2 (Con.falsee, Con.truee)} | |
1607 | ||
1608 | fun genCase (T {isEnum, tagBits, variants, ...}, | |
1609 | {cases: Cases.t, | |
1610 | conRep: Con.t -> ConRep.t, | |
1611 | isObjptr: bool, | |
1612 | notSmall: Label.t option, | |
1613 | smallDefault: Label.t option, | |
1614 | test: Operand.t}) | |
1615 | : Statement.t list * Transfer.t = | |
1616 | let | |
1617 | val tagSize = WordSize.fromBits tagBits | |
1618 | val testBits = Type.width (Operand.ty test) | |
1619 | val testSize = WordSize.fromBits testBits | |
1620 | val cases = | |
1621 | Vector.keepAllMap | |
1622 | (cases, fn {con, dst, dstHasArg} => | |
1623 | case conRep con of | |
1624 | ConRep.ShiftAndTag {tag, ty, ...} => | |
1625 | let | |
1626 | val test = Operand.cast (test, Type.padToWidth (ty, testBits)) | |
1627 | val (test, ss) = Statement.resize (test, ty) | |
1628 | val transfer = | |
1629 | Goto {args = if dstHasArg | |
1630 | then Vector.new1 test | |
1631 | else Vector.new0 (), | |
1632 | dst = dst} | |
1633 | in | |
1634 | SOME (WordX.resize (tag, testSize), | |
1635 | Block.new {statements = Vector.fromList ss, | |
1636 | transfer = transfer}) | |
1637 | end | |
1638 | | ConRep.Tag {tag, ...} => | |
1639 | let | |
1640 | val transfer = | |
1641 | Goto {args = if dstHasArg | |
1642 | then Vector.new1 test | |
1643 | else Vector.new0 (), | |
1644 | dst = dst} | |
1645 | in | |
1646 | SOME (WordX.resize (tag, testSize), | |
1647 | Block.new {statements = Vector.new0 (), | |
1648 | transfer = transfer}) | |
1649 | end | |
1650 | | _ => NONE) | |
1651 | val cases = QuickSort.sortVector (cases, fn ((w, _), (w', _)) => | |
1652 | WordX.le (w, w', {signed = false})) | |
1653 | val tagOp = | |
1654 | if isObjptr | |
1655 | then Operand.cast (test, Type.bits testBits) | |
1656 | else test | |
1657 | val (tagOp, ss) = | |
1658 | if isEnum | |
1659 | then (tagOp, []) | |
1660 | else | |
1661 | let | |
1662 | val mask = | |
1663 | Operand.word (WordX.resize | |
1664 | (WordX.max (tagSize, {signed = false}), | |
1665 | testSize)) | |
1666 | val (s, tagOp) = Statement.andb (tagOp, mask) | |
1667 | in | |
1668 | (tagOp, [s]) | |
1669 | end | |
1670 | val default = | |
1671 | if Vector.length variants = Vector.length cases | |
1672 | then notSmall | |
1673 | else | |
1674 | case (notSmall, smallDefault) of | |
1675 | (NONE, _) => smallDefault | |
1676 | | (_, NONE) => notSmall | |
1677 | | (SOME notSmall, SOME smallDefault) => | |
1678 | let | |
1679 | val (s, test) = | |
1680 | Statement.andb | |
1681 | (Operand.cast (test, Type.bits testBits), | |
1682 | Operand.word (WordX.fromIntInf (3, testSize))) | |
1683 | val t = | |
1684 | Switch | |
1685 | (Switch.T | |
1686 | {cases = Vector.new1 (WordX.zero testSize, | |
1687 | notSmall), | |
1688 | default = SOME smallDefault, | |
1689 | size = testSize, | |
1690 | test = test}) | |
1691 | in | |
1692 | SOME (Block.new {statements = Vector.new1 s, | |
1693 | transfer = t}) | |
1694 | end | |
1695 | val transfer = | |
1696 | Switch (Switch.T {cases = cases, | |
1697 | default = default, | |
1698 | size = testSize, | |
1699 | test = tagOp}) | |
1700 | in | |
1701 | (ss, transfer) | |
1702 | end | |
1703 | ||
1704 | val genCase = | |
1705 | Trace.trace | |
1706 | ("PackedRepresentation.Small.genCase", | |
1707 | fn (s, {test, ...}) => | |
1708 | Layout.tuple [layout s, | |
1709 | Layout.record [("test", Operand.layout test)]], | |
1710 | Layout.tuple2 (List.layout Statement.layout, Transfer.layout)) | |
1711 | genCase | |
1712 | end | |
1713 | ||
1714 | structure TyconRep = | |
1715 | struct | |
1716 | datatype t = | |
1717 | One of {con: Con.t, | |
1718 | tupleRep: TupleRep.t} | |
1719 | | Objptrs of Objptrs.t | |
1720 | | Small of Small.t | |
1721 | | SmallAndBox of {box: {con: Con.t, | |
1722 | objptr: ObjptrRep.t}, | |
1723 | rep: Rep.t, | |
1724 | small: Small.t} | |
1725 | | SmallAndObjptr of {objptr: {component: Component.t, | |
1726 | con: Con.t}, | |
1727 | rep: Rep.t, | |
1728 | small: Small.t} | |
1729 | | SmallAndObjptrs of {objptrs: Objptrs.t, | |
1730 | rep: Rep.t, | |
1731 | small: Small.t} | |
1732 | | Unit | |
1733 | ||
1734 | fun layout (r: t): Layout.t = | |
1735 | let | |
1736 | open Layout | |
1737 | in | |
1738 | case r of | |
1739 | One {con, tupleRep} => | |
1740 | seq [str "One ", | |
1741 | record [("con", Con.layout con), | |
1742 | ("tupleRep", TupleRep.layout tupleRep)]] | |
1743 | | Objptrs ps => | |
1744 | seq [str "Objptrs ", Objptrs.layout ps] | |
1745 | | Small s => | |
1746 | seq [str "Small ", Small.layout s] | |
1747 | | SmallAndBox {box = {con, objptr}, rep, small} => | |
1748 | seq [str "SmallAndBox ", | |
1749 | record [("box", | |
1750 | record [("con", Con.layout con), | |
1751 | ("objptr", ObjptrRep.layout objptr)]), | |
1752 | ("rep", Rep.layout rep), | |
1753 | ("small", Small.layout small)]] | |
1754 | | SmallAndObjptr {objptr = {component, con}, rep, small} => | |
1755 | seq [str "SmallAndObjptr ", | |
1756 | record | |
1757 | [("objptr", | |
1758 | record [("component", Component.layout component), | |
1759 | ("con", Con.layout con)]), | |
1760 | ("rep", Rep.layout rep), | |
1761 | ("small", Small.layout small)]] | |
1762 | | SmallAndObjptrs {objptrs, rep, small} => | |
1763 | seq [str "SmallAndObjptrs ", | |
1764 | record [("objptrs", Objptrs.layout objptrs), | |
1765 | ("rep", Rep.layout rep), | |
1766 | ("small", Small.layout small)]] | |
1767 | | Unit => str "Unit" | |
1768 | end | |
1769 | ||
1770 | val bool = Small Small.bool | |
1771 | ||
1772 | val unit = Unit | |
1773 | ||
1774 | val rep: t -> Rep.t = | |
1775 | fn One {tupleRep, ...} => TupleRep.rep tupleRep | |
1776 | | Objptrs p => Objptrs.rep p | |
1777 | | Small s => Small.rep s | |
1778 | | SmallAndBox {rep, ...} => rep | |
1779 | | SmallAndObjptr {rep, ...} => rep | |
1780 | | SmallAndObjptrs {rep, ...} => rep | |
1781 | | Unit => Rep.unit | |
1782 | ||
1783 | fun equals (r, r') = Rep.equals (rep r, rep r') | |
1784 | ||
1785 | val objptrBytes = Runtime.objptrSize | |
1786 | val objptrBits = Promise.lazy (fn () => Bytes.toBits (objptrBytes ())) | |
1787 | val objptrBitsAsInt = Promise.lazy (fn () => Bits.toInt (objptrBits ())) | |
1788 | ||
1789 | local | |
1790 | val aWithout = | |
1791 | Promise.lazy | |
1792 | (fn () => Array.tabulate (objptrBitsAsInt () + 1, fn i => | |
1793 | IntInf.pow (2, i))) | |
1794 | (* If there is an objptr, then multiply the number of tags by | |
1795 | * 3/4 to remove all the tags that have 00 as their low bits. | |
1796 | *) | |
1797 | val aWith = | |
1798 | Promise.lazy | |
1799 | (fn () => Array.tabulate (objptrBitsAsInt () + 1, fn i => | |
1800 | (Array.sub (aWithout (), i) * 3) div 4)) | |
1801 | in | |
1802 | fun numTagsAvailable {tagBits: int, withObjptr: bool} = | |
1803 | let | |
1804 | val a = if withObjptr then aWith () else aWithout () | |
1805 | in | |
1806 | Array.sub (a, tagBits) | |
1807 | end | |
1808 | ||
1809 | val numTagsAvailable = | |
1810 | Trace.trace | |
1811 | ("PackedRepresentation.TyconRep.numTagsAvailable", | |
1812 | fn {tagBits, withObjptr} => | |
1813 | Layout.record [("tagBits", Int.layout tagBits), | |
1814 | ("withObjptr", Bool.layout withObjptr)], | |
1815 | IntInf.layout) | |
1816 | numTagsAvailable | |
1817 | ||
1818 | fun tagBitsNeeded {numVariants: int, withObjptr: bool}: Bits.t = | |
1819 | let | |
1820 | val numVariants = Int.toIntInf numVariants | |
1821 | val a = if withObjptr then aWith () else aWithout () | |
1822 | in | |
1823 | case (BinarySearch.smallest | |
1824 | (a, fn numTags => numVariants <= numTags)) of | |
1825 | NONE => Error.bug "PackedRepresentation.TyconRep.tagBitsNeeded" | |
1826 | | SOME i => Bits.fromInt i | |
1827 | end | |
1828 | ||
1829 | val tagBitsNeeded = | |
1830 | Trace.trace | |
1831 | ("PackedRepresentation.TyconRep.tagBitsNeeded", | |
1832 | fn {numVariants, withObjptr} => | |
1833 | Layout.record [("numVariants", Int.layout numVariants), | |
1834 | ("withObjptr", Bool.layout withObjptr)], | |
1835 | Bits.layout) | |
1836 | tagBitsNeeded | |
1837 | end | |
1838 | ||
1839 | fun make (variants: {args: {isMutable: bool, | |
1840 | rep: Rep.t, | |
1841 | ty: S.Type.t} vector, | |
1842 | con: Con.t, | |
1843 | objptrTycon: ObjptrTycon.t} vector) | |
1844 | : t * {con: Con.t, rep: ConRep.t} vector = | |
1845 | if 0 = Vector.length variants | |
1846 | then (Unit, Vector.new0 ()) | |
1847 | else if 1 = Vector.length variants | |
1848 | then | |
1849 | let | |
1850 | val {args, con, objptrTycon} = Vector.sub (variants, 0) | |
1851 | val tupleRep = | |
1852 | TupleRep.make (objptrTycon, args, | |
1853 | {forceBox = false, | |
1854 | isVector = false}) | |
1855 | val conRep = ConRep.Tuple tupleRep | |
1856 | in | |
1857 | (One {con = con, tupleRep = tupleRep}, | |
1858 | Vector.new1 {con = con, rep = conRep}) | |
1859 | end | |
1860 | else if (2 = Vector.length variants | |
1861 | andalso let | |
1862 | val c = #con (Vector.first variants) | |
1863 | in | |
1864 | Con.equals (c, Con.falsee) | |
1865 | orelse Con.equals (c, Con.truee) | |
1866 | end) | |
1867 | then (bool, Vector.new2 ({con = Con.falsee, rep = ConRep.falsee}, | |
1868 | {con = Con.truee, rep = ConRep.truee})) | |
1869 | else | |
1870 | let | |
1871 | val numSmall : IntInf.t ref = ref 0 | |
1872 | val small = Array.array (objptrBitsAsInt (), []) | |
1873 | val big = ref [] | |
1874 | val () = | |
1875 | Vector.foreach | |
1876 | (variants, fn {args, con, objptrTycon} => | |
1877 | let | |
1878 | val tr = | |
1879 | TupleRep.make (objptrTycon, args, | |
1880 | {forceBox = false, | |
1881 | isVector = false}) | |
1882 | fun makeBig () = | |
1883 | List.push (big, | |
1884 | {con = con, | |
1885 | objptrTycon = objptrTycon, | |
1886 | tupleRep = tr}) | |
1887 | val Rep.T {rep, ty} = TupleRep.rep tr | |
1888 | in | |
1889 | case rep of | |
1890 | Rep.NonObjptr => | |
1891 | let | |
1892 | val i = Bits.toInt (Type.width ty) | |
1893 | in | |
1894 | if i >= objptrBitsAsInt () | |
1895 | then makeBig () | |
1896 | else | |
1897 | let | |
1898 | val {component, selects} = | |
1899 | case tr of | |
1900 | TupleRep.Direct z => z | |
1901 | | TupleRep.Indirect _ => | |
1902 | Error.bug "PackedRepresentation.TyconRep.make: small Indirect" | |
1903 | val () = IntInf.inc numSmall | |
1904 | val () = | |
1905 | Array.update | |
1906 | (small, i, | |
1907 | {component = component, | |
1908 | con = con, | |
1909 | objptrTycon = objptrTycon, | |
1910 | selects = selects} | |
1911 | :: Array.sub (small, i)) | |
1912 | in | |
1913 | () | |
1914 | end | |
1915 | end | |
1916 | | Rep.Objptr _ => makeBig () | |
1917 | end) | |
1918 | val big = !big | |
1919 | val numSmall = !numSmall | |
1920 | fun noLargerThan (i, ac) = | |
1921 | if i < 0 | |
1922 | then ac | |
1923 | else (noLargerThan | |
1924 | (i - 1, | |
1925 | List.fold (Array.sub (small, i), ac, op ::))) | |
1926 | (* Box as few things as possible so that the number of tags available | |
1927 | * is >= the number of unboxed variants. | |
1928 | *) | |
1929 | fun loop (maxSmallWidth: int, | |
1930 | forced, | |
1931 | withObjptr: bool, | |
1932 | numSmall: IntInf.t) = | |
1933 | if 0 = numSmall | |
1934 | then (maxSmallWidth, forced, []) | |
1935 | else | |
1936 | let | |
1937 | val vs = Array.sub (small, maxSmallWidth) | |
1938 | in | |
1939 | if List.isEmpty vs | |
1940 | then loop (maxSmallWidth - 1, forced, | |
1941 | withObjptr, numSmall) | |
1942 | else | |
1943 | let | |
1944 | val numTags = | |
1945 | numTagsAvailable | |
1946 | {tagBits = objptrBitsAsInt () - maxSmallWidth, | |
1947 | withObjptr = withObjptr} | |
1948 | in | |
1949 | if numSmall <= numTags | |
1950 | then | |
1951 | (* There are enough tag bits available. *) | |
1952 | (maxSmallWidth, | |
1953 | forced, | |
1954 | noLargerThan (maxSmallWidth - 1, vs)) | |
1955 | else | |
1956 | let | |
1957 | val z = Int.toIntInf (List.length vs) | |
1958 | val remaining = numSmall - z | |
1959 | in | |
1960 | if remaining <= numTags | |
1961 | then | |
1962 | let | |
1963 | val (front, back) = | |
1964 | List.splitAt | |
1965 | (vs, | |
1966 | IntInf.toInt | |
1967 | (numSmall - numTags)) | |
1968 | in | |
1969 | (maxSmallWidth, | |
1970 | List.append (front, forced), | |
1971 | noLargerThan (maxSmallWidth - 1, | |
1972 | back)) | |
1973 | end | |
1974 | else loop (maxSmallWidth - 1, | |
1975 | vs @ forced, | |
1976 | true, | |
1977 | remaining) | |
1978 | end | |
1979 | end | |
1980 | end | |
1981 | val (maxSmallWidth, forced, small) = | |
1982 | loop (objptrBitsAsInt () - 1, [], | |
1983 | not (List.isEmpty big), | |
1984 | numSmall) | |
1985 | val maxSmallWidth = Bits.fromInt maxSmallWidth | |
1986 | val withObjptr = not (List.isEmpty big andalso List.isEmpty forced) | |
1987 | (* ShiftAndTag all the small. *) | |
1988 | val (small: Small.t option, smallReps) = | |
1989 | let | |
1990 | val numSmall = List.length small | |
1991 | in | |
1992 | if 0 = numSmall | |
1993 | then (NONE, Vector.new0 ()) | |
1994 | else | |
1995 | let | |
1996 | val tagBits = | |
1997 | tagBitsNeeded {numVariants = numSmall, | |
1998 | withObjptr = withObjptr} | |
1999 | val r = ref 0w0 | |
2000 | fun getTag (): IntInf.t = | |
2001 | let | |
2002 | val w = !r | |
2003 | val w = | |
2004 | if withObjptr andalso | |
2005 | 0w0 = Word.andb (w, 0w3) | |
2006 | then w + 0w1 | |
2007 | else w | |
2008 | val () = r := w + 0w1 | |
2009 | in | |
2010 | Word.toIntInf w | |
2011 | end | |
2012 | val small = | |
2013 | Vector.fromListMap | |
2014 | (small, fn {component, con, selects, ...} => | |
2015 | let | |
2016 | val tag = | |
2017 | WordX.fromIntInf | |
2018 | (getTag (), WordSize.fromBits tagBits) | |
2019 | val isUnit = Type.isUnit (Component.ty component) | |
2020 | val component = | |
2021 | Component.padToWidth | |
2022 | (component, maxSmallWidth) | |
2023 | val selects = Selects.lshift (selects, tagBits) | |
2024 | val ty = | |
2025 | Type.seq | |
2026 | (Vector.new2 | |
2027 | (Type.ofWordX tag, | |
2028 | Component.ty component)) | |
2029 | val ty = | |
2030 | if withObjptr | |
2031 | then Type.resize (ty, objptrBits ()) | |
2032 | else Type.padToPrim ty | |
2033 | in | |
2034 | {component = component, | |
2035 | con = con, | |
2036 | isUnit = isUnit, | |
2037 | selects = selects, | |
2038 | tag = tag, | |
2039 | ty = ty} | |
2040 | end) | |
2041 | val ty = Type.sum (Vector.map (small, #ty)) | |
2042 | val rep = Rep.T {rep = Rep.NonObjptr, ty = ty} | |
2043 | val reps = | |
2044 | Vector.map | |
2045 | (small, fn {component, con, isUnit, selects, tag, ty, | |
2046 | ...} => | |
2047 | {con = con, | |
2048 | rep = if isUnit | |
2049 | then ConRep.Tag {tag = tag, ty = ty} | |
2050 | else (ConRep.ShiftAndTag | |
2051 | {component = component, | |
2052 | selects = selects, | |
2053 | tag = tag, | |
2054 | ty = ty})}) | |
2055 | val isEnum = | |
2056 | Vector.forall | |
2057 | (reps, fn {rep, ...} => | |
2058 | case rep of | |
2059 | ConRep.Tag _ => true | |
2060 | | _ => false) | |
2061 | in | |
2062 | (SOME (Small.T {isEnum = isEnum, | |
2063 | rep = rep, | |
2064 | tagBits = tagBits, | |
2065 | variants = Vector.map (reps, #con)}), | |
2066 | reps) | |
2067 | end | |
2068 | end | |
2069 | fun makeSmallObjptr {component, con, objptrTycon, selects} = | |
2070 | {con = con, | |
2071 | objptr = (ObjptrRep.box | |
2072 | (Component.padToWidth (component, objptrBits ()), | |
2073 | objptrTycon, selects))} | |
2074 | fun makeBigObjptr {con, objptrTycon, tupleRep} = | |
2075 | let | |
2076 | val objptr = | |
2077 | case tupleRep of | |
2078 | TupleRep.Direct {component, selects} => | |
2079 | ObjptrRep.box (component, objptrTycon, selects) | |
2080 | | TupleRep.Indirect p => p | |
2081 | in | |
2082 | {con = con, objptr = objptr} | |
2083 | end | |
2084 | fun sumWithSmall (r: Rep.t): Rep.t = | |
2085 | Rep.T {rep = Rep.Objptr {endsIn00 = false}, | |
2086 | ty = Type.sum (Vector.new2 | |
2087 | (Rep.ty r, | |
2088 | Rep.ty (Small.rep (valOf small))))} | |
2089 | fun box () = | |
2090 | let | |
2091 | val objptrs = | |
2092 | Vector.concat | |
2093 | [Vector.fromListMap (forced, makeSmallObjptr), | |
2094 | Vector.fromListMap (big, makeBigObjptr)] | |
2095 | val sumRep = | |
2096 | if 1 = Vector.length objptrs | |
2097 | then | |
2098 | let | |
2099 | val objptr = Vector.first objptrs | |
2100 | val small = valOf small | |
2101 | val rep = | |
2102 | sumWithSmall (ObjptrRep.rep (#objptr objptr)) | |
2103 | in | |
2104 | SmallAndBox {box = objptr, | |
2105 | rep = rep, | |
2106 | small = small} | |
2107 | end | |
2108 | else | |
2109 | let | |
2110 | val ty = | |
2111 | Type.sum | |
2112 | (Vector.map (objptrs, ObjptrRep.ty o #objptr)) | |
2113 | val objptrs = | |
2114 | Objptrs.make | |
2115 | {rep = Rep.T {rep = Rep.Objptr {endsIn00 = true}, | |
2116 | ty = ty}, | |
2117 | variants = objptrs} | |
2118 | in | |
2119 | case small of | |
2120 | NONE => Objptrs objptrs | |
2121 | | SOME small => | |
2122 | SmallAndObjptrs | |
2123 | {objptrs = objptrs, | |
2124 | rep = sumWithSmall (Objptrs.rep objptrs), | |
2125 | small = small} | |
2126 | end | |
2127 | in | |
2128 | (sumRep, | |
2129 | Vector.map (objptrs, fn {con, objptr} => | |
2130 | {con = con, | |
2131 | rep = ConRep.box objptr})) | |
2132 | end | |
2133 | val (sumRep, objptrReps) = | |
2134 | case (forced, big) of | |
2135 | ([], []) => (Small (valOf small), Vector.new0 ()) | |
2136 | | ([], [{con, tupleRep, ...}]) => | |
2137 | (* If there is only one big and it is an objptr that | |
2138 | * ends in 00, then there is no need to box it. | |
2139 | *) | |
2140 | (case tupleRep of | |
2141 | TupleRep.Direct {component, ...} => | |
2142 | let | |
2143 | val rep = TupleRep.rep tupleRep | |
2144 | in | |
2145 | if Rep.isObjptrEndingIn00 rep | |
2146 | then | |
2147 | let | |
2148 | val small = valOf small | |
2149 | in | |
2150 | (SmallAndObjptr | |
2151 | {objptr = {component = component, | |
2152 | con = con}, | |
2153 | rep = sumWithSmall rep, | |
2154 | small = small}, | |
2155 | Vector.new1 | |
2156 | {con = con, | |
2157 | rep = ConRep.Tuple tupleRep}) | |
2158 | end | |
2159 | else box () | |
2160 | end | |
2161 | | _ => box ()) | |
2162 | | _ => box () | |
2163 | in | |
2164 | (sumRep, Vector.concat [smallReps, objptrReps]) | |
2165 | end | |
2166 | ||
2167 | val make = | |
2168 | Trace.trace | |
2169 | ("PackedRepresentation.TyconRep.make", | |
2170 | Vector.layout | |
2171 | (fn {args, con, ...} => | |
2172 | Layout.record [("args", Vector.layout (Rep.layout o #rep) args), | |
2173 | ("con", Con.layout con)]), | |
2174 | Layout.tuple2 (layout, | |
2175 | Vector.layout | |
2176 | (fn {con, rep} => | |
2177 | Layout.record [("con", Con.layout con), | |
2178 | ("rep", ConRep.layout rep)]))) | |
2179 | make | |
2180 | ||
2181 | fun genCase (r: t, | |
2182 | {cases: Cases.t, | |
2183 | conRep: Con.t -> ConRep.t, | |
2184 | default: Label.t option, | |
2185 | test: unit -> Operand.t}) | |
2186 | : Statement.t list * Transfer.t * Block.t list = | |
2187 | let | |
2188 | val (statements, transfer) = | |
2189 | case r of | |
2190 | One {con, ...} => | |
2191 | (case (Vector.length cases, default) of | |
2192 | (1, _) => | |
2193 | (* Use _ instead of NONE for the default becuase | |
2194 | * there may be an unreachable default case. | |
2195 | *) | |
2196 | let | |
2197 | val {con = c, dst, dstHasArg} = | |
2198 | Vector.first cases | |
2199 | in | |
2200 | if not (Con.equals (c, con)) | |
2201 | then Error.bug "PackedRepresentation.genCase: One" | |
2202 | else | |
2203 | ([], | |
2204 | Goto {args = (if dstHasArg | |
2205 | then Vector.new1 (test ()) | |
2206 | else Vector.new0 ()), | |
2207 | dst = dst}) | |
2208 | end | |
2209 | | (0, SOME l) => | |
2210 | ([], Goto {dst = l, args = Vector.new0 ()}) | |
2211 | | _ => Error.bug "PackedRepresentation.genCase: One,prim datatype with more than one case") | |
2212 | | Objptrs ps => | |
2213 | Objptrs.genCase (ps, {cases = cases, | |
2214 | conRep = conRep, | |
2215 | default = default, | |
2216 | test = test ()}) | |
2217 | | Small s => | |
2218 | Small.genCase (s, {cases = cases, | |
2219 | conRep = conRep, | |
2220 | isObjptr = false, | |
2221 | notSmall = NONE, | |
2222 | smallDefault = default, | |
2223 | test = test ()}) | |
2224 | | SmallAndBox {box = {con, objptr}, small, ...} => | |
2225 | let | |
2226 | val notSmall = | |
2227 | case Vector.peek (cases, fn {con = c, ...} => | |
2228 | Con.equals (c, con)) of | |
2229 | NONE => default | |
2230 | | SOME {dst, dstHasArg, ...} => | |
2231 | let | |
2232 | val test = | |
2233 | Operand.cast (test (), | |
2234 | ObjptrRep.ty objptr) | |
2235 | in | |
2236 | SOME | |
2237 | (Block.new | |
2238 | {statements = Vector.new0 (), | |
2239 | transfer = | |
2240 | Goto {args = (if dstHasArg | |
2241 | then Vector.new1 test | |
2242 | else Vector.new0 ()), | |
2243 | dst = dst}}) | |
2244 | end | |
2245 | in | |
2246 | Small.genCase (small, {cases = cases, | |
2247 | conRep = conRep, | |
2248 | isObjptr = true, | |
2249 | notSmall = notSmall, | |
2250 | smallDefault = default, | |
2251 | test = test ()}) | |
2252 | end | |
2253 | | SmallAndObjptr {objptr = {component, con}, small, ...} => | |
2254 | let | |
2255 | val notSmall = | |
2256 | case Vector.peek (cases, fn {con = c, ...} => | |
2257 | Con.equals (c, con)) of | |
2258 | NONE => default | |
2259 | | SOME {dst, dstHasArg, ...} => | |
2260 | let | |
2261 | val args = | |
2262 | if dstHasArg | |
2263 | then (Vector.new1 | |
2264 | (Operand.cast | |
2265 | (test (), | |
2266 | Component.ty component))) | |
2267 | else Vector.new0 () | |
2268 | in | |
2269 | SOME (Block.new | |
2270 | {statements = Vector.new0 (), | |
2271 | transfer = Goto {args = args, | |
2272 | dst = dst}}) | |
2273 | end | |
2274 | in | |
2275 | Small.genCase (small, {cases = cases, | |
2276 | conRep = conRep, | |
2277 | isObjptr = true, | |
2278 | notSmall = notSmall, | |
2279 | smallDefault = default, | |
2280 | test = test ()}) | |
2281 | end | |
2282 | | SmallAndObjptrs {objptrs, small, ...} => | |
2283 | let | |
2284 | val test = test () | |
2285 | val (ss, t) = | |
2286 | Objptrs.genCase | |
2287 | (objptrs, {cases = cases, | |
2288 | conRep = conRep, | |
2289 | default = default, | |
2290 | test = (Operand.cast | |
2291 | (test, Objptrs.ty objptrs))}) | |
2292 | val objptr = | |
2293 | Block.new {statements = Vector.fromList ss, | |
2294 | transfer = t} | |
2295 | in | |
2296 | Small.genCase (small, {cases = cases, | |
2297 | conRep = conRep, | |
2298 | isObjptr = true, | |
2299 | notSmall = SOME objptr, | |
2300 | smallDefault = default, | |
2301 | test = test}) | |
2302 | end | |
2303 | | Unit => Error.bug "PackedRepresentation.TyconRep.genCase: Unit" | |
2304 | in | |
2305 | (statements, transfer, Block.getExtra ()) | |
2306 | end | |
2307 | ||
2308 | val genCase = | |
2309 | Trace.trace | |
2310 | ("PackedRepresentation.TyconRep.genCase", | |
2311 | fn (r, {cases, default, ...}) => | |
2312 | Layout.tuple [layout r, | |
2313 | Layout.record | |
2314 | [("cases", Cases.layout cases), | |
2315 | ("default", Option.layout Label.layout default)]], | |
2316 | Layout.tuple3 (List.layout Statement.layout, | |
2317 | Transfer.layout, | |
2318 | List.layout Block.layout)) | |
2319 | genCase | |
2320 | end | |
2321 | ||
2322 | structure Value: | |
2323 | sig | |
2324 | type 'a t | |
2325 | ||
2326 | val affect: 'a t * 'b t -> unit | |
2327 | val constant: 'a -> 'a t | |
2328 | val fixedPoint: unit -> unit | |
2329 | val get: 'a t -> 'a | |
2330 | val layout: ('a -> Layout.t) -> 'a t -> Layout.t | |
2331 | val new: {compute: unit -> 'a, | |
2332 | equals: 'a * 'a -> bool, | |
2333 | init: 'a} -> 'a t | |
2334 | end = | |
2335 | struct | |
2336 | structure Dep = | |
2337 | struct | |
2338 | datatype t = T of {affects: t list ref, | |
2339 | compute: unit -> {change: bool}, | |
2340 | needToCompute: bool ref} | |
2341 | ||
2342 | (* A list of all ts such that !needToCompute = true. *) | |
2343 | val todo: t list ref = ref [] | |
2344 | ||
2345 | fun recompute (me as T {needToCompute, ...}) = | |
2346 | if !needToCompute | |
2347 | then () | |
2348 | else (List.push (todo, me) | |
2349 | ; needToCompute := true) | |
2350 | ||
2351 | fun fixedPoint () = | |
2352 | case !todo of | |
2353 | [] => () | |
2354 | | T {affects, compute, needToCompute, ...} :: l => | |
2355 | let | |
2356 | val () = todo := l | |
2357 | val () = needToCompute := false | |
2358 | val {change} = compute () | |
2359 | val () = | |
2360 | if change | |
2361 | then List.foreach (!affects, recompute) | |
2362 | else () | |
2363 | in | |
2364 | fixedPoint () | |
2365 | end | |
2366 | ||
2367 | fun affect (T {affects, ...}, z) = List.push (affects, z) | |
2368 | ||
2369 | fun new {compute: unit -> 'a, | |
2370 | equals: 'a * 'a -> bool, | |
2371 | init: 'a}: t * 'a ref = | |
2372 | let | |
2373 | val r: 'a ref = ref init | |
2374 | val affects = ref [] | |
2375 | val compute = | |
2376 | fn () => | |
2377 | let | |
2378 | val old = !r | |
2379 | val new = compute () | |
2380 | val () = r := new | |
2381 | in | |
2382 | {change = not (equals (old, new))} | |
2383 | end | |
2384 | val me = T {affects = affects, | |
2385 | compute = compute, | |
2386 | needToCompute = ref false} | |
2387 | val () = recompute me | |
2388 | in | |
2389 | (me, r) | |
2390 | end | |
2391 | end | |
2392 | ||
2393 | datatype 'a t = | |
2394 | Constant of 'a | |
2395 | | Variable of Dep.t * 'a ref | |
2396 | ||
2397 | val get = | |
2398 | fn Constant a => a | |
2399 | | Variable (_, r) => !r | |
2400 | ||
2401 | fun layout l v = l (get v) | |
2402 | ||
2403 | val constant = Constant | |
2404 | ||
2405 | fun new z = Variable (Dep.new z) | |
2406 | ||
2407 | val affect = | |
2408 | fn (Variable (d, _), Variable (d', _)) => Dep.affect (d, d') | |
2409 | | (Constant _, _) => () | |
2410 | | (_, Constant _) => Error.bug "PackedRepresentation.Value.affect: Constant" | |
2411 | ||
2412 | val fixedPoint = Dep.fixedPoint | |
2413 | end | |
2414 | ||
2415 | fun compute (program as Ssa.Program.T {datatypes, ...}) = | |
2416 | let | |
2417 | type tyconRepAndCons = | |
2418 | (TyconRep.t * {con: Con.t, rep: ConRep.t} vector) Value.t | |
2419 | val {get = conInfo: Con.t -> {rep: ConRep.t ref, | |
2420 | tyconRep: tyconRepAndCons}, | |
2421 | set = setConInfo, ...} = | |
2422 | Property.getSetOnce (Con.plist, Property.initRaise ("info", Con.layout)) | |
2423 | val {get = tupleRep: S.Type.t -> TupleRep.t Value.t, | |
2424 | set = setTupleRep, ...} = | |
2425 | Property.getSetOnce (S.Type.plist, | |
2426 | Property.initRaise ("tupleRep", S.Type.layout)) | |
2427 | val setTupleRep = | |
2428 | Trace.trace | |
2429 | ("PackedRepresentation.setTupleRep", | |
2430 | S.Type.layout o #1, Layout.ignore) | |
2431 | setTupleRep | |
2432 | fun vectorRep (t: S.Type.t): TupleRep.t = Value.get (tupleRep t) | |
2433 | fun setVectorRep (t: S.Type.t, tr: TupleRep.t): unit = | |
2434 | setTupleRep (t, Value.new {compute = fn () => tr, | |
2435 | equals = TupleRep.equals, | |
2436 | init = tr}) | |
2437 | val setVectorRep = | |
2438 | Trace.trace2 | |
2439 | ("PackedRepresentation.setVectorRep", | |
2440 | S.Type.layout, TupleRep.layout, Unit.layout) | |
2441 | setVectorRep | |
2442 | val {get = tyconRep: Tycon.t -> tyconRepAndCons, set = setTyconRep, ...} = | |
2443 | Property.getSetOnce (Tycon.plist, | |
2444 | Property.initRaise ("tyconRep", Tycon.layout)) | |
2445 | (* Initialize the datatypes. *) | |
2446 | val typeRepRef = ref (fn _ => Error.bug "PackedRepresentation.typeRep") | |
2447 | fun typeRep t = !typeRepRef t | |
2448 | val datatypes = | |
2449 | Vector.map | |
2450 | (datatypes, fn S.Datatype.T {cons, tycon} => | |
2451 | let | |
2452 | val cons = | |
2453 | Vector.map | |
2454 | (cons, fn {args, con} => | |
2455 | {args = args, | |
2456 | con = con, | |
2457 | objptrTycon = ObjptrTycon.new ()}) | |
2458 | fun compute () = | |
2459 | let | |
2460 | val (tr, cons) = | |
2461 | TyconRep.make | |
2462 | (Vector.map | |
2463 | (cons, fn {args, con, objptrTycon} => | |
2464 | {args = Vector.map (Prod.dest args, | |
2465 | fn {elt, isMutable} => | |
2466 | {isMutable = isMutable, | |
2467 | rep = Value.get (typeRep elt), | |
2468 | ty = elt}), | |
2469 | con = con, | |
2470 | objptrTycon = objptrTycon})) | |
2471 | val () = | |
2472 | Vector.foreach | |
2473 | (cons, fn {con, rep} => #rep (conInfo con) := rep) | |
2474 | in | |
2475 | (tr, cons) | |
2476 | end | |
2477 | fun equals ((r, v), (r', v')) = | |
2478 | TyconRep.equals (r, r') | |
2479 | andalso Vector.equals (v, v', fn ({con = c, rep = r}, | |
2480 | {con = c', rep = r'}) => | |
2481 | Con.equals (c, c') | |
2482 | andalso ConRep.equals (r, r')) | |
2483 | val rep = | |
2484 | Value.new {compute = compute, | |
2485 | equals = equals, | |
2486 | init = (TyconRep.unit, Vector.new0 ())} | |
2487 | val () = setTyconRep (tycon, rep) | |
2488 | val () = Vector.foreach (cons, fn {con, ...} => | |
2489 | setConInfo (con, {rep = ref ConRep.unit, | |
2490 | tyconRep = rep})) | |
2491 | in | |
2492 | {cons = cons, | |
2493 | rep = rep, | |
2494 | tycon = tycon} | |
2495 | end) | |
2496 | val delayedObjectTypes | |
2497 | : (unit -> (ObjptrTycon.t * ObjectType.t) option) list ref = | |
2498 | ref [] | |
2499 | val {get = typeRep: S.Type.t -> Rep.t Value.t, ...} = | |
2500 | Property.get | |
2501 | (S.Type.plist, | |
2502 | Property.initRec | |
2503 | (fn (t, typeRep: S.Type.t -> Rep.t Value.t) => | |
2504 | let | |
2505 | val constant = Value.constant | |
2506 | val nonObjptr = constant o Rep.nonObjptr | |
2507 | datatype z = datatype S.Type.dest | |
2508 | in | |
2509 | case S.Type.dest t of | |
2510 | CPointer => nonObjptr (Type.cpointer ()) | |
2511 | | Datatype tycon => | |
2512 | let | |
2513 | val r = tyconRep tycon | |
2514 | fun compute () = TyconRep.rep (#1 (Value.get r)) | |
2515 | val r' = Value.new {compute = compute, | |
2516 | equals = Rep.equals, | |
2517 | init = Rep.unit} | |
2518 | val () = Value.affect (r, r') | |
2519 | in | |
2520 | r' | |
2521 | end | |
2522 | | IntInf => | |
2523 | constant (Rep.T {rep = Rep.Objptr {endsIn00 = false}, | |
2524 | ty = Type.intInf ()}) | |
2525 | | Object {args, con} => | |
2526 | (case con of | |
2527 | ObjectCon.Con con => | |
2528 | let | |
2529 | val {rep, tyconRep} = conInfo con | |
2530 | fun compute () = ConRep.rep (!rep) | |
2531 | val r = Value.new {compute = compute, | |
2532 | equals = Rep.equals, | |
2533 | init = Rep.unit} | |
2534 | val () = Value.affect (tyconRep, r) | |
2535 | in | |
2536 | r | |
2537 | end | |
2538 | | ObjectCon.Tuple => | |
2539 | let | |
2540 | val opt = ObjptrTycon.new () | |
2541 | val rs = | |
2542 | Vector.map (Prod.dest args, typeRep o #elt) | |
2543 | fun compute () = | |
2544 | TupleRep.make | |
2545 | (opt, | |
2546 | Vector.map2 (rs, Prod.dest args, | |
2547 | fn (r, {elt, isMutable}) => | |
2548 | {isMutable = isMutable, | |
2549 | rep = Value.get r, | |
2550 | ty = elt}), | |
2551 | {forceBox = false, isVector = false}) | |
2552 | val tr = | |
2553 | Value.new {compute = compute, | |
2554 | equals = TupleRep.equals, | |
2555 | init = TupleRep.unit} | |
2556 | val () = Vector.foreach (rs, fn r => | |
2557 | Value.affect (r, tr)) | |
2558 | val hasIdentity = Prod.someIsMutable args | |
2559 | val () = | |
2560 | List.push | |
2561 | (delayedObjectTypes, fn () => | |
2562 | case Value.get tr of | |
2563 | TupleRep.Indirect opr => | |
2564 | SOME | |
2565 | (opt, (ObjectType.Normal | |
2566 | {hasIdentity = hasIdentity, | |
2567 | ty = ObjptrRep.componentsTy opr})) | |
2568 | | _ => NONE) | |
2569 | val () = setTupleRep (t, tr) | |
2570 | fun compute () = TupleRep.rep (Value.get tr) | |
2571 | val r = Value.new {compute = compute, | |
2572 | equals = Rep.equals, | |
2573 | init = Rep.unit} | |
2574 | val () = Value.affect (tr, r) | |
2575 | in | |
2576 | r | |
2577 | end | |
2578 | | ObjectCon.Vector => | |
2579 | let | |
2580 | val hasIdentity = Prod.someIsMutable args | |
2581 | val args = Prod.dest args | |
2582 | fun tupleRep opt = | |
2583 | let | |
2584 | val tr = | |
2585 | TupleRep.make | |
2586 | (opt, | |
2587 | Vector.map | |
2588 | (args, fn {elt, isMutable} => | |
2589 | {isMutable = isMutable, | |
2590 | rep = Value.get (typeRep elt), | |
2591 | ty = elt}), | |
2592 | {forceBox = true, | |
2593 | isVector = true}) | |
2594 | val () = setVectorRep (t, tr) | |
2595 | in | |
2596 | tr | |
2597 | end | |
2598 | fun now opt = (ignore (tupleRep opt); opt) | |
2599 | fun delay () = | |
2600 | let | |
2601 | val opt = ObjptrTycon.new () | |
2602 | val () = | |
2603 | List.push | |
2604 | (delayedObjectTypes, fn () => | |
2605 | let | |
2606 | (* Delay computing tupleRep until the | |
2607 | * delayedObjectTypes are computed | |
2608 | * because the vector component types | |
2609 | * may not be known yet. | |
2610 | *) | |
2611 | val tr = tupleRep opt | |
2612 | val ty = | |
2613 | case tr of | |
2614 | TupleRep.Direct _ => | |
2615 | TupleRep.ty tr | |
2616 | | TupleRep.Indirect opr => | |
2617 | ObjptrRep.componentsTy opr | |
2618 | in | |
2619 | SOME (opt, | |
2620 | ObjectType.Array | |
2621 | {elt = ty, | |
2622 | hasIdentity = hasIdentity}) | |
2623 | end) | |
2624 | in | |
2625 | opt | |
2626 | end | |
2627 | val opt = | |
2628 | if 1 <> Vector.length args | |
2629 | then delay () | |
2630 | else | |
2631 | let | |
2632 | val {elt, isMutable, ...} = | |
2633 | Vector.sub (args, 0) | |
2634 | in | |
2635 | if isMutable | |
2636 | then delay () | |
2637 | else | |
2638 | (case S.Type.dest elt of | |
2639 | S.Type.Word s => | |
2640 | let | |
2641 | val nBits = WordSize.bits s | |
2642 | val nInt = Bits.toInt nBits | |
2643 | in | |
2644 | if nInt = 8 | |
2645 | orelse nInt = 16 | |
2646 | orelse nInt = 32 | |
2647 | orelse nInt = 64 | |
2648 | then | |
2649 | now | |
2650 | (ObjptrTycon.wordVector nBits) | |
2651 | else delay () | |
2652 | end | |
2653 | | _ => delay ()) | |
2654 | end | |
2655 | in | |
2656 | constant | |
2657 | (Rep.T {rep = Rep.Objptr {endsIn00 = true}, | |
2658 | ty = Type.objptr opt}) | |
2659 | end) | |
2660 | | Real s => nonObjptr (Type.real s) | |
2661 | | Thread => | |
2662 | constant (Rep.T {rep = Rep.Objptr {endsIn00 = true}, | |
2663 | ty = Type.thread ()}) | |
2664 | | Weak t => | |
2665 | let | |
2666 | val opt = ObjptrTycon.new () | |
2667 | val rep = | |
2668 | Rep.T {rep = Rep.Objptr {endsIn00 = true}, | |
2669 | ty = Type.objptr opt} | |
2670 | val r = typeRep t | |
2671 | fun compute () = | |
2672 | if Rep.isObjptr (Value.get r) | |
2673 | then rep | |
2674 | else Rep.unit | |
2675 | val r' = Value.new {compute = compute, | |
2676 | equals = Rep.equals, | |
2677 | init = Rep.unit} | |
2678 | val () = Value.affect (r, r') | |
2679 | val () = | |
2680 | List.push | |
2681 | (delayedObjectTypes, fn () => | |
2682 | let | |
2683 | val r = Value.get r | |
2684 | in | |
2685 | if Rep.isObjptr r | |
2686 | then SOME (opt, ObjectType.Weak (SOME (Rep.ty r))) | |
2687 | else NONE | |
2688 | end) | |
2689 | in | |
2690 | r' | |
2691 | end | |
2692 | | Word s => nonObjptr (Type.word s) | |
2693 | end)) | |
2694 | val () = typeRepRef := typeRep | |
2695 | val _ = typeRep (S.Type.vector1 (S.Type.word WordSize.byte)) | |
2696 | (* Establish dependence between constructor argument type representations | |
2697 | * and tycon representations. | |
2698 | *) | |
2699 | val () = | |
2700 | Vector.foreach | |
2701 | (datatypes, fn {cons, rep, ...} => | |
2702 | Vector.foreach | |
2703 | (cons, fn {args, ...} => | |
2704 | Vector.foreach (Prod.dest args, fn {elt, ...} => | |
2705 | Value.affect (typeRep elt, rep)))) | |
2706 | val typeRep = | |
2707 | Trace.trace | |
2708 | ("PackedRepresentation.typeRep", | |
2709 | S.Type.layout, Value.layout Rep.layout) | |
2710 | typeRep | |
2711 | val () = S.Program.foreachVar (program, fn (_, t) => ignore (typeRep t)) | |
2712 | val () = Value.fixedPoint () | |
2713 | val conRep = ! o #rep o conInfo | |
2714 | val tyconRep = #1 o Value.get o tyconRep | |
2715 | val objectTypes = | |
2716 | Vector.fold | |
2717 | (datatypes, [], fn ({cons, ...}, ac) => | |
2718 | Vector.fold | |
2719 | (cons, ac, fn ({args, con, objptrTycon, ...}, ac) => | |
2720 | case conRep con of | |
2721 | ConRep.Tuple (TupleRep.Indirect opr) => | |
2722 | (objptrTycon, | |
2723 | ObjectType.Normal {hasIdentity = Prod.someIsMutable args, | |
2724 | ty = ObjptrRep.componentsTy opr}) :: ac | |
2725 | | _ => ac)) | |
2726 | val objectTypes = ref objectTypes | |
2727 | val () = | |
2728 | List.foreach (!delayedObjectTypes, fn f => | |
2729 | Option.app (f (), fn z => List.push (objectTypes, z))) | |
2730 | val objectTypes = Vector.fromList (!objectTypes) | |
2731 | fun diagnostic () = | |
2732 | Control.diagnostics | |
2733 | (fn display => | |
2734 | (display (Layout.str "Representations:") | |
2735 | ; (Vector.foreach | |
2736 | (datatypes, fn {cons, tycon, ...} => | |
2737 | let | |
2738 | open Layout | |
2739 | in | |
2740 | display (seq [Tycon.layout tycon, | |
2741 | str " ", TyconRep.layout (tyconRep tycon)]) | |
2742 | ; display (indent | |
2743 | (Vector.layout | |
2744 | (fn {con, ...} => | |
2745 | record [("con", Con.layout con), | |
2746 | ("rep", ConRep.layout (conRep con))]) | |
2747 | cons, | |
2748 | 2)) | |
2749 | end)))) | |
2750 | fun toRtype (t: S.Type.t): Type.t option = | |
2751 | let | |
2752 | val ty = Rep.ty (Value.get (typeRep t)) | |
2753 | in | |
2754 | if Type.isUnit ty | |
2755 | then NONE | |
2756 | else SOME (Type.padToPrim ty) | |
2757 | end | |
2758 | fun makeSrc (v, oper) {index} = oper (Vector.sub (v, index)) | |
2759 | fun genCase {cases, default, test, tycon} = | |
2760 | TyconRep.genCase (tyconRep tycon, | |
2761 | {cases = cases, | |
2762 | conRep = conRep, | |
2763 | default = default, | |
2764 | test = test}) | |
2765 | val tupleRep = Value.get o tupleRep | |
2766 | val tupleRep = | |
2767 | Trace.trace | |
2768 | ("PackedRepresentation.tupleRep", | |
2769 | S.Type.layout, TupleRep.layout) | |
2770 | tupleRep | |
2771 | fun object {args, con, dst, objectTy, oper} = | |
2772 | let | |
2773 | val src = makeSrc (args, oper) | |
2774 | in | |
2775 | case con of | |
2776 | NONE => TupleRep.tuple (tupleRep objectTy, {dst = dst, src = src}) | |
2777 | | SOME con => ConRep.conApp (conRep con, {dst = dst, src = src}) | |
2778 | end | |
2779 | fun getSelects (con, objectTy) = | |
2780 | let | |
2781 | datatype z = datatype ObjectCon.t | |
2782 | in | |
2783 | case con of | |
2784 | Con con => | |
2785 | (case conRep con of | |
2786 | ConRep.ShiftAndTag {selects, ...} => (selects, NONE) | |
2787 | | ConRep.Tuple tr => (TupleRep.selects tr, NONE) | |
2788 | | _ => Error.bug "PackedRepresentation.getSelects: Con,non-select") | |
2789 | | Tuple => (TupleRep.selects (tupleRep objectTy), NONE) | |
2790 | | Vector => | |
2791 | case vectorRep objectTy of | |
2792 | tr as TupleRep.Indirect pr => | |
2793 | (TupleRep.selects tr, | |
2794 | SOME (Type.bytes (ObjptrRep.componentsTy pr))) | |
2795 | | _ => Error.bug "PackedRepresentation.getSelects: Vector,non-Indirect" | |
2796 | end | |
2797 | fun select {base, baseTy, dst, offset} = | |
2798 | case S.Type.dest baseTy of | |
2799 | S.Type.Object {con, ...} => | |
2800 | let | |
2801 | val (ss, eltWidth) = getSelects (con, baseTy) | |
2802 | in | |
2803 | Selects.select | |
2804 | (ss, {base = base, | |
2805 | eltWidth = eltWidth, | |
2806 | dst = dst, | |
2807 | offset = offset}) | |
2808 | end | |
2809 | | _ => Error.bug "PackedRepresentation.select: non-object" | |
2810 | fun update {base, baseTy, offset, value} = | |
2811 | case S.Type.dest baseTy of | |
2812 | S.Type.Object {con, ...} => | |
2813 | let | |
2814 | val (ss, eltWidth) = getSelects (con, baseTy) | |
2815 | in | |
2816 | Selects.update (ss, {base = base, | |
2817 | eltWidth = eltWidth, | |
2818 | offset = offset, | |
2819 | value = value}) | |
2820 | end | |
2821 | | _ => Error.bug "PackedRepresentation.update: non-object" | |
2822 | in | |
2823 | {diagnostic = diagnostic, | |
2824 | genCase = genCase, | |
2825 | object = object, | |
2826 | objectTypes = objectTypes, | |
2827 | select = select, | |
2828 | toRtype = toRtype, | |
2829 | update = update} | |
2830 | end | |
2831 | ||
2832 | end |