Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009,2011,2014,2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2008 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 | functor SsaToRssa (S: SSA_TO_RSSA_STRUCTS): SSA_TO_RSSA = | |
11 | struct | |
12 | ||
13 | open S | |
14 | open Rssa | |
15 | ||
16 | datatype z = datatype WordSize.prim | |
17 | ||
18 | structure S = Ssa | |
19 | ||
20 | local | |
21 | open Ssa | |
22 | in | |
23 | structure Base = Base | |
24 | end | |
25 | ||
26 | local | |
27 | open Runtime | |
28 | in | |
29 | structure GCField = GCField | |
30 | end | |
31 | ||
32 | structure Prim = | |
33 | struct | |
34 | open Prim | |
35 | ||
36 | type t = Type.t Prim.t | |
37 | end | |
38 | ||
39 | structure CFunction = | |
40 | struct | |
41 | open CFunction | |
42 | open Type.BuiltInCFunction | |
43 | ||
44 | type t = Type.t CFunction.t | |
45 | ||
46 | structure CType = | |
47 | struct | |
48 | open CType | |
49 | val gcState = CPointer | |
50 | val intInf = Objptr | |
51 | val string = Objptr | |
52 | val thread = CPointer (* CHECK; thread (= objptr) would be better? *) | |
53 | end | |
54 | ||
55 | datatype z = datatype Convention.t | |
56 | datatype z = datatype SymbolScope.t | |
57 | datatype z = datatype Target.t | |
58 | ||
59 | val copyCurrentThread = fn () => | |
60 | T {args = Vector.new1 (Type.gcState ()), | |
61 | convention = Cdecl, | |
62 | kind = Kind.Runtime {bytesNeeded = NONE, | |
63 | ensuresBytesFree = false, | |
64 | mayGC = true, | |
65 | maySwitchThreads = false, | |
66 | modifiesFrontier = true, | |
67 | readsStackTop = true, | |
68 | writesStackTop = true}, | |
69 | prototype = (Vector.new1 CType.gcState, NONE), | |
70 | return = Type.unit, | |
71 | symbolScope = Private, | |
72 | target = Direct "GC_copyCurrentThread"} | |
73 | ||
74 | (* CHECK; thread as objptr *) | |
75 | val copyThread = fn () => | |
76 | T {args = Vector.new2 (Type.gcState (), Type.thread ()), | |
77 | convention = Cdecl, | |
78 | kind = Kind.Runtime {bytesNeeded = NONE, | |
79 | ensuresBytesFree = false, | |
80 | mayGC = true, | |
81 | maySwitchThreads = false, | |
82 | modifiesFrontier = true, | |
83 | readsStackTop = true, | |
84 | writesStackTop = true}, | |
85 | prototype = let | |
86 | open CType | |
87 | in | |
88 | (Vector.new2 (CPointer, CPointer), SOME CPointer) | |
89 | end, | |
90 | return = Type.thread (), | |
91 | symbolScope = Private, | |
92 | target = Direct "GC_copyThread"} | |
93 | ||
94 | val halt = fn () => | |
95 | T {args = Vector.new2 (Type.gcState (), Type.cint ()), | |
96 | convention = Cdecl, | |
97 | kind = Kind.Runtime {bytesNeeded = NONE, | |
98 | ensuresBytesFree = false, | |
99 | mayGC = false, | |
100 | maySwitchThreads = false, | |
101 | modifiesFrontier = true, | |
102 | readsStackTop = true, | |
103 | writesStackTop = true}, | |
104 | prototype = (Vector.new2 (CType.gcState, CType.cint ()), NONE), | |
105 | return = Type.unit, | |
106 | symbolScope = Private, | |
107 | target = Direct "MLton_halt"} | |
108 | ||
109 | fun gcArrayAllocate {return} = | |
110 | T {args = Vector.new4 (Type.gcState (), | |
111 | Type.csize (), | |
112 | Type.seqIndex (), | |
113 | Type.objptrHeader ()), | |
114 | convention = Cdecl, | |
115 | kind = Kind.Runtime {bytesNeeded = NONE, | |
116 | ensuresBytesFree = true, | |
117 | mayGC = true, | |
118 | maySwitchThreads = false, | |
119 | modifiesFrontier = true, | |
120 | readsStackTop = true, | |
121 | writesStackTop = true}, | |
122 | prototype = (Vector.new4 (CType.gcState, | |
123 | CType.csize (), | |
124 | CType.seqIndex (), | |
125 | CType.objptrHeader ()), | |
126 | SOME CType.objptr), | |
127 | return = return, | |
128 | symbolScope = Private, | |
129 | target = Direct "GC_arrayAllocate"} | |
130 | ||
131 | fun gcArrayCopy (dt, st) = | |
132 | T {args = Vector.new6 (Type.gcState (), | |
133 | dt, | |
134 | Type.seqIndex (), | |
135 | st, | |
136 | Type.seqIndex (), | |
137 | Type.seqIndex ()), | |
138 | convention = Cdecl, | |
139 | kind = Kind.Runtime {bytesNeeded = NONE, | |
140 | ensuresBytesFree = true, | |
141 | mayGC = true, | |
142 | maySwitchThreads = false, | |
143 | modifiesFrontier = true, | |
144 | readsStackTop = true, | |
145 | writesStackTop = true}, | |
146 | prototype = (Vector.new6 (CType.gcState, | |
147 | CType.Objptr, | |
148 | CType.seqIndex (), | |
149 | CType.Objptr, | |
150 | CType.seqIndex (), | |
151 | CType.seqIndex ()), | |
152 | NONE), | |
153 | return = Type.unit, | |
154 | symbolScope = Private, | |
155 | target = Direct "GC_arrayCopy"} | |
156 | ||
157 | val returnToC = fn () => | |
158 | T {args = Vector.new0 (), | |
159 | convention = Cdecl, | |
160 | kind = Kind.Runtime {bytesNeeded = NONE, | |
161 | ensuresBytesFree = false, | |
162 | mayGC = true, | |
163 | maySwitchThreads = true, | |
164 | modifiesFrontier = true, | |
165 | readsStackTop = true, | |
166 | writesStackTop = true}, | |
167 | prototype = (Vector.new0 (), NONE), | |
168 | return = Type.unit, | |
169 | symbolScope = Private, | |
170 | target = Direct "Thread_returnToC"} | |
171 | ||
172 | (* CHECK; thread as objptr *) | |
173 | val threadSwitchTo = fn () => | |
174 | T {args = Vector.new3 (Type.gcState (), Type.thread (), Type.csize ()), | |
175 | convention = Cdecl, | |
176 | kind = Kind.Runtime {bytesNeeded = NONE, | |
177 | ensuresBytesFree = true, | |
178 | mayGC = true, | |
179 | maySwitchThreads = true, | |
180 | modifiesFrontier = true, | |
181 | readsStackTop = true, | |
182 | writesStackTop = true}, | |
183 | prototype = (Vector.new3 (CType.gcState, | |
184 | CType.thread, | |
185 | CType.csize ()), | |
186 | NONE), | |
187 | return = Type.unit, | |
188 | symbolScope = Private, | |
189 | target = Direct "GC_switchToThread"} | |
190 | ||
191 | (* CHECK; weak as objptr *) | |
192 | fun weakCanGet {arg} = | |
193 | T {args = Vector.new2 (Type.gcState (), arg), | |
194 | convention = Cdecl, | |
195 | kind = Kind.Runtime {bytesNeeded = NONE, | |
196 | ensuresBytesFree = false, | |
197 | mayGC = false, | |
198 | maySwitchThreads = false, | |
199 | modifiesFrontier = false, | |
200 | readsStackTop = false, | |
201 | writesStackTop = false}, | |
202 | prototype = (Vector.new2 (CType.gcState, CType.cpointer), | |
203 | SOME CType.bool), | |
204 | return = Type.bool, | |
205 | symbolScope = Private, | |
206 | target = Direct "GC_weakCanGet"} | |
207 | ||
208 | (* CHECK; weak as objptr *) | |
209 | fun weakGet {arg, return} = | |
210 | T {args = Vector.new2 (Type.gcState (), arg), | |
211 | convention = Cdecl, | |
212 | kind = Kind.Runtime {bytesNeeded = NONE, | |
213 | ensuresBytesFree = false, | |
214 | mayGC = false, | |
215 | maySwitchThreads = false, | |
216 | modifiesFrontier = false, | |
217 | readsStackTop = false, | |
218 | writesStackTop = false}, | |
219 | prototype = (Vector.new2 (CType.gcState, CType.cpointer), | |
220 | SOME CType.cpointer), | |
221 | return = return, | |
222 | symbolScope = Private, | |
223 | target = Direct "GC_weakGet"} | |
224 | ||
225 | (* CHECK; weak as objptr *) | |
226 | fun weakNew {arg, return} = | |
227 | T {args = Vector.new3 (Type.gcState (), Type.objptrHeader (), arg), | |
228 | convention = Cdecl, | |
229 | kind = Kind.Runtime {bytesNeeded = NONE, | |
230 | ensuresBytesFree = false, | |
231 | mayGC = true, | |
232 | maySwitchThreads = false, | |
233 | modifiesFrontier = true, | |
234 | readsStackTop = true, | |
235 | writesStackTop = true}, | |
236 | prototype = (Vector.new3 (CType.gcState, | |
237 | CType.objptrHeader (), | |
238 | CType.cpointer), | |
239 | SOME (CType.cpointer)), | |
240 | return = return, | |
241 | symbolScope = Private, | |
242 | target = Direct "GC_weakNew"} | |
243 | ||
244 | val worldSave = fn () => | |
245 | T {args = Vector.new2 (Type.gcState (), Type.string ()), | |
246 | convention = Cdecl, | |
247 | kind = Kind.Runtime {bytesNeeded = NONE, | |
248 | ensuresBytesFree = false, | |
249 | mayGC = true, | |
250 | maySwitchThreads = false, | |
251 | modifiesFrontier = true, | |
252 | readsStackTop = true, | |
253 | writesStackTop = true}, | |
254 | prototype = (Vector.new2 (CType.gcState, CType.cpointer), NONE), | |
255 | return = Type.unit, | |
256 | symbolScope = Private, | |
257 | target = Direct "GC_saveWorld"} | |
258 | ||
259 | (* CHECK; share with objptr *) | |
260 | fun share t = | |
261 | T {args = Vector.new2 (Type.gcState (), t), | |
262 | convention = Cdecl, | |
263 | kind = Kind.Runtime {bytesNeeded = NONE, | |
264 | ensuresBytesFree = false, | |
265 | mayGC = true, (* MLton.share works by tracing an object. | |
266 | * Make sure all the GC invariants are true, | |
267 | * because tracing might encounter the current | |
268 | * stack in the heap. | |
269 | *) | |
270 | maySwitchThreads = false, | |
271 | modifiesFrontier = true, (* actually, just readsFrontier *) | |
272 | readsStackTop = true, | |
273 | writesStackTop = true}, | |
274 | prototype = (Vector.new2 (CType.gcState, CType.cpointer), NONE), | |
275 | return = Type.unit, | |
276 | symbolScope = Private, | |
277 | target = Direct "GC_share"} | |
278 | ||
279 | (* CHECK; size with objptr *) | |
280 | fun size t = | |
281 | T {args = Vector.new2 (Type.gcState (), t), | |
282 | convention = Cdecl, | |
283 | kind = Kind.Runtime {bytesNeeded = NONE, | |
284 | ensuresBytesFree = false, | |
285 | mayGC = true, (* MLton.size works by tracing an object. | |
286 | * Make sure all the GC invariants are true, | |
287 | * because tracing might encounter the current | |
288 | * stack in the heap. | |
289 | *) | |
290 | maySwitchThreads = false, | |
291 | modifiesFrontier = true, | |
292 | readsStackTop = true, | |
293 | writesStackTop = true}, | |
294 | prototype = (Vector.new2 (CType.gcState, CType.cpointer), | |
295 | SOME (CType.csize ())), | |
296 | return = Type.csize (), | |
297 | symbolScope = Private, | |
298 | target = Direct "GC_size"} | |
299 | ||
300 | fun amAllocationProfiling () = | |
301 | Control.ProfileAlloc = !Control.profile | |
302 | val intInfBinary = fn name => | |
303 | CFunction.T {args = Vector.new4 (Type.gcState (), | |
304 | Type.intInf (), | |
305 | Type.intInf (), | |
306 | Type.csize ()), | |
307 | convention = Cdecl, | |
308 | kind = CFunction.Kind.Runtime {bytesNeeded = SOME 3, | |
309 | ensuresBytesFree = false, | |
310 | mayGC = false, | |
311 | maySwitchThreads = false, | |
312 | modifiesFrontier = true, | |
313 | readsStackTop = amAllocationProfiling (), | |
314 | writesStackTop = false}, | |
315 | prototype = (Vector.new4 (CType.gcState, | |
316 | CType.intInf, | |
317 | CType.intInf, | |
318 | CType.csize ()), | |
319 | SOME CType.intInf), | |
320 | return = Type.intInf (), | |
321 | symbolScope = Private, | |
322 | target = Direct (Prim.Name.toString name)} | |
323 | val intInfCompare = fn name => | |
324 | (* CHECK; cint would be better? *) | |
325 | CFunction.T {args = Vector.new3 (Type.gcState (), | |
326 | Type.intInf (), | |
327 | Type.intInf ()), | |
328 | convention = Cdecl, | |
329 | kind = CFunction.Kind.Runtime {bytesNeeded = NONE, | |
330 | ensuresBytesFree = false, | |
331 | mayGC = false, | |
332 | maySwitchThreads = false, | |
333 | modifiesFrontier = false, | |
334 | readsStackTop = false, | |
335 | writesStackTop = false}, | |
336 | prototype = (Vector.new3 (CType.gcState, | |
337 | CType.intInf, | |
338 | CType.intInf), | |
339 | SOME CType.compareRes), | |
340 | return = Type.compareRes, | |
341 | symbolScope = Private, | |
342 | target = Direct (Prim.Name.toString name)} | |
343 | val intInfShift = fn name => | |
344 | CFunction.T {args = Vector.new4 (Type.gcState (), | |
345 | Type.intInf (), | |
346 | Type.shiftArg, | |
347 | Type.csize ()), | |
348 | convention = Cdecl, | |
349 | kind = CFunction.Kind.Runtime {bytesNeeded = SOME 3, | |
350 | ensuresBytesFree = false, | |
351 | mayGC = false, | |
352 | maySwitchThreads = false, | |
353 | modifiesFrontier = true, | |
354 | readsStackTop = amAllocationProfiling (), | |
355 | writesStackTop = false}, | |
356 | prototype = (Vector.new4 (CType.gcState, | |
357 | CType.intInf, | |
358 | CType.shiftArg, | |
359 | CType.csize ()), | |
360 | SOME CType.intInf), | |
361 | return = Type.intInf (), | |
362 | symbolScope = Private, | |
363 | target = Direct (Prim.Name.toString name)} | |
364 | val intInfToString = fn name => | |
365 | (* CHECK; cint would be better? *) | |
366 | CFunction.T {args = Vector.new4 (Type.gcState (), | |
367 | Type.intInf (), | |
368 | Type.word WordSize.word32, | |
369 | Type.csize ()), | |
370 | convention = Cdecl, | |
371 | kind = CFunction.Kind.Runtime {bytesNeeded = SOME 3, | |
372 | ensuresBytesFree = false, | |
373 | mayGC = false, | |
374 | maySwitchThreads = false, | |
375 | modifiesFrontier = true, | |
376 | readsStackTop = amAllocationProfiling (), | |
377 | writesStackTop = false}, | |
378 | prototype = (Vector.new4 (CType.gcState, | |
379 | CType.intInf, | |
380 | CType.Int32, | |
381 | CType.csize ()), | |
382 | SOME CType.string), | |
383 | return = Type.string (), | |
384 | symbolScope = Private, | |
385 | target = Direct (Prim.Name.toString name)} | |
386 | val intInfUnary = fn name => | |
387 | CFunction.T {args = Vector.new3 (Type.gcState (), | |
388 | Type.intInf (), | |
389 | Type.csize ()), | |
390 | convention = Cdecl, | |
391 | kind = CFunction.Kind.Runtime {bytesNeeded = SOME 2, | |
392 | ensuresBytesFree = false, | |
393 | mayGC = false, | |
394 | maySwitchThreads = false, | |
395 | modifiesFrontier = true, | |
396 | readsStackTop = amAllocationProfiling (), | |
397 | writesStackTop = false}, | |
398 | prototype = (Vector.new3 (CType.gcState, | |
399 | CType.intInf, | |
400 | CType.csize ()), | |
401 | SOME CType.intInf), | |
402 | return = Type.intInf (), | |
403 | symbolScope = Private, | |
404 | target = Direct (Prim.Name.toString name)} | |
405 | end | |
406 | ||
407 | structure Name = | |
408 | struct | |
409 | open Prim.Name | |
410 | ||
411 | type t = Type.t t | |
412 | ||
413 | fun cFunctionRaise (n: t): CFunction.t = | |
414 | let | |
415 | datatype z = datatype CFunction.Convention.t | |
416 | datatype z = datatype CFunction.SymbolScope.t | |
417 | datatype z = datatype CFunction.Target.t | |
418 | val name = toString n | |
419 | val real = Type.real | |
420 | val word = Type.word | |
421 | val vanilla = CFunction.vanilla | |
422 | fun wordCType (s, sg) = CType.word (s, sg) | |
423 | fun realCType s = CType.real s | |
424 | fun coerce (t1, ct1, t2, ct2) = | |
425 | vanilla {args = Vector.new1 t1, | |
426 | name = name, | |
427 | prototype = (Vector.new1 ct1, SOME ct2), | |
428 | return = t2} | |
429 | local | |
430 | fun make n s = | |
431 | let | |
432 | val t = real s | |
433 | val ct = CType.real s | |
434 | in | |
435 | vanilla {args = Vector.new (n, t), | |
436 | name = name, | |
437 | prototype = (Vector.new (n, ct), SOME ct), | |
438 | return = t} | |
439 | end | |
440 | in | |
441 | val realBinary = make 2 | |
442 | val realTernary = make 3 | |
443 | val realUnary = make 1 | |
444 | end | |
445 | fun realCompare s = | |
446 | let | |
447 | val t = real s | |
448 | in | |
449 | vanilla {args = Vector.new2 (t, t), | |
450 | name = name, | |
451 | prototype = let | |
452 | val t = CType.real s | |
453 | in | |
454 | (Vector.new2 (t, t), SOME CType.bool) | |
455 | end, | |
456 | return = Type.bool} | |
457 | end | |
458 | local | |
459 | fun make n (s, sg) = | |
460 | let | |
461 | val t = word s | |
462 | val ct = CType.word (s, sg) | |
463 | in | |
464 | vanilla {args = Vector.new (n, t), | |
465 | name = name, | |
466 | prototype = (Vector.new (n, ct), SOME ct), | |
467 | return = t} | |
468 | end | |
469 | fun makeOverflows n (s, sg) = | |
470 | let | |
471 | val t = word s | |
472 | val ct = CType.word (s, sg) | |
473 | in | |
474 | vanilla {args = Vector.new (n, t), | |
475 | name = name ^ "Overflows", | |
476 | prototype = (Vector.new (n, ct), SOME CType.bool), | |
477 | return = Type.bool} | |
478 | end | |
479 | in | |
480 | val wordBinary = make 2 | |
481 | val wordBinaryOverflows = makeOverflows 2 | |
482 | val wordUnary = make 1 | |
483 | val wordUnaryOverflows = makeOverflows 1 | |
484 | end | |
485 | fun wordCompare (s, sg) = | |
486 | let | |
487 | val t = word s | |
488 | val ct = CType.word (s, sg) | |
489 | in | |
490 | vanilla {args = Vector.new2 (t, t), | |
491 | name = name, | |
492 | prototype = (Vector.new2 (ct, ct), SOME CType.bool), | |
493 | return = Type.bool} | |
494 | end | |
495 | fun wordShift (s, sg) = | |
496 | let | |
497 | val t = word s | |
498 | val ct = CType.word (s, sg) | |
499 | in | |
500 | vanilla {args = Vector.new2 (t, Type.shiftArg), | |
501 | name = name, | |
502 | prototype = (Vector.new2 (ct, CType.shiftArg), SOME ct), | |
503 | return = t} | |
504 | end | |
505 | in | |
506 | case n of | |
507 | MLton_bug => CFunction.bug () | |
508 | | Real_Math_acos s => realUnary s | |
509 | | Real_Math_asin s => realUnary s | |
510 | | Real_Math_atan s => realUnary s | |
511 | | Real_Math_atan2 s => realBinary s | |
512 | | Real_Math_cos s => realUnary s | |
513 | | Real_Math_exp s => realUnary s | |
514 | | Real_Math_ln s => realUnary s | |
515 | | Real_Math_log10 s => realUnary s | |
516 | | Real_Math_sin s => realUnary s | |
517 | | Real_Math_sqrt s => realUnary s | |
518 | | Real_Math_tan s => realUnary s | |
519 | | Real_abs s => realUnary s | |
520 | | Real_add s => realBinary s | |
521 | | Real_castToWord (s1, s2) => | |
522 | coerce (real s1, realCType s1, | |
523 | word s2, wordCType (s2, {signed = false})) | |
524 | | Real_div s => realBinary s | |
525 | | Real_equal s => realCompare s | |
526 | | Real_ldexp s => | |
527 | let | |
528 | val t = real s | |
529 | val ct = CType.real s | |
530 | in | |
531 | vanilla {args = Vector.new2 (t, Type.cint ()), | |
532 | name = name, | |
533 | prototype = (Vector.new2 (ct, CType.cint ()), | |
534 | SOME ct), | |
535 | return = t} | |
536 | end | |
537 | | Real_le s => realCompare s | |
538 | | Real_lt s => realCompare s | |
539 | | Real_mul s => realBinary s | |
540 | | Real_muladd s => realTernary s | |
541 | | Real_mulsub s => realTernary s | |
542 | | Real_neg s => realUnary s | |
543 | | Real_qequal s => realCompare s | |
544 | | Real_rndToReal (s1, s2) => | |
545 | coerce (real s1, realCType s1, real s2, realCType s2) | |
546 | | Real_rndToWord (s1, s2, sg) => | |
547 | coerce (real s1, realCType s1, | |
548 | word s2, wordCType (s2, sg)) | |
549 | | Real_round s => realUnary s | |
550 | | Real_sub s => realBinary s | |
551 | | Thread_returnToC => CFunction.returnToC () | |
552 | | Word_add s => wordBinary (s, {signed = false}) | |
553 | | Word_addCheck (s, sg) => wordBinaryOverflows (s, sg) | |
554 | | Word_andb s => wordBinary (s, {signed = false}) | |
555 | | Word_castToReal (s1, s2) => | |
556 | coerce (word s1, wordCType (s1, {signed = false}), | |
557 | real s2, realCType s2) | |
558 | | Word_equal s => wordCompare (s, {signed = false}) | |
559 | | Word_extdToWord (s1, s2, sg) => | |
560 | coerce (word s1, wordCType (s1, sg), | |
561 | word s2, wordCType (s2, {signed = false})) | |
562 | | Word_lshift s => wordShift (s, {signed = false}) | |
563 | | Word_lt z => wordCompare z | |
564 | | Word_mul z => wordBinary z | |
565 | | Word_mulCheck (s, sg) => wordBinaryOverflows (s, sg) | |
566 | | Word_neg s => wordUnary (s, {signed = true}) | |
567 | | Word_negCheck s => wordUnaryOverflows (s, {signed = true}) | |
568 | | Word_notb s => wordUnary (s, {signed = false}) | |
569 | | Word_orb s => wordBinary (s, {signed = false}) | |
570 | | Word_quot z => wordBinary z | |
571 | | Word_rem z => wordBinary z | |
572 | | Word_rndToReal (s1, s2, sg) => | |
573 | coerce (word s1, wordCType (s1, sg), | |
574 | real s2, realCType s2) | |
575 | | Word_xorb s => wordBinary (s, {signed = false}) | |
576 | | Word_rol s => wordShift (s, {signed = false}) | |
577 | | Word_ror s => wordShift (s, {signed = false}) | |
578 | | Word_rshift z => wordShift z | |
579 | | Word_sub s => wordBinary (s, {signed = false}) | |
580 | | Word_subCheck (s, sg) => wordBinaryOverflows (s, sg) | |
581 | | _ => Error.bug "SsaToRssa.Name.cFunctionRaise" | |
582 | end | |
583 | ||
584 | fun cFunction n = SOME (cFunctionRaise n) handle _ => NONE | |
585 | end | |
586 | ||
587 | datatype z = datatype Operand.t | |
588 | datatype z = datatype Statement.t | |
589 | datatype z = datatype Transfer.t | |
590 | ||
591 | structure PackedRepresentation = PackedRepresentation (structure Rssa = Rssa | |
592 | structure Ssa = Ssa) | |
593 | ||
594 | structure Type = | |
595 | struct | |
596 | open Type | |
597 | ||
598 | fun scale (ty: t): Scale.t = | |
599 | case Scale.fromBytes (bytes ty) of | |
600 | NONE => Error.bug "SsaToRssa.Type.scale" | |
601 | | SOME s => s | |
602 | end | |
603 | ||
604 | val cardSizeLog2 : IntInf.t = 8 (* must agree with CARD_SIZE_LOG2 in gc.c *) | |
605 | ||
606 | fun updateCard (addr: Operand.t): Statement.t list = | |
607 | let | |
608 | val index = Var.newNoname () | |
609 | (* CHECK; WordSize.objptr or WordSize.cpointer? *) | |
610 | val sz = WordSize.objptr () | |
611 | val indexTy = Type.word sz | |
612 | val cardElemSize = WordSize.fromBits Bits.inByte | |
613 | in | |
614 | [PrimApp {args = (Vector.new2 | |
615 | (Operand.cast (addr, Type.bits (WordSize.bits sz)), | |
616 | Operand.word | |
617 | (WordX.fromIntInf (cardSizeLog2, WordSize.shiftArg)))), | |
618 | dst = SOME (index, indexTy), | |
619 | prim = Prim.wordRshift (sz, {signed = false})}, | |
620 | Move {dst = (ArrayOffset | |
621 | {base = Runtime GCField.CardMapAbsolute, | |
622 | index = Var {ty = indexTy, var = index}, | |
623 | offset = Bytes.zero, | |
624 | scale = Scale.One, | |
625 | ty = Type.word cardElemSize}), | |
626 | src = Operand.word (WordX.one cardElemSize)}] | |
627 | end | |
628 | ||
629 | fun convertWordSize (ws: WordSize.t): WordSize.t = | |
630 | WordSize.roundUpToPrim ws | |
631 | ||
632 | fun convertWordX (w: WordX.t): WordX.t = | |
633 | WordX.resize (w, convertWordSize (WordX.size w)) | |
634 | ||
635 | fun convert (program as S.Program.T {functions, globals, main, ...}, | |
636 | {codegenImplementsPrim: Rssa.Type.t Rssa.Prim.t -> bool}): Rssa.Program.t = | |
637 | let | |
638 | val {diagnostic, genCase, object, objectTypes, select, toRtype, update} = | |
639 | PackedRepresentation.compute program | |
640 | val objectTypes = Vector.concat [ObjectType.basic (), objectTypes] | |
641 | val () = | |
642 | Vector.foreachi | |
643 | (objectTypes, fn (i, (opt, _)) => ObjptrTycon.setIndex (opt, i)) | |
644 | val objectTypes = Vector.map (objectTypes, #2) | |
645 | val () = diagnostic () | |
646 | ||
647 | val newObjectTypes = ref [] | |
648 | local | |
649 | val h = HashSet.new {hash = fn {bits, ...} => | |
650 | Bits.toWord bits} | |
651 | in | |
652 | fun allocRawOpt width = | |
653 | (#opt o HashSet.lookupOrInsert) | |
654 | (h, Bits.toWord width, | |
655 | fn {bits, ...} => Bits.equals (bits, width), | |
656 | fn () => | |
657 | let | |
658 | val rawElt = Type.bits width | |
659 | val rawTy = ObjectType.Array {elt = rawElt, hasIdentity = true} | |
660 | val rawOpt = ObjptrTycon.new () | |
661 | val () = | |
662 | ObjptrTycon.setIndex | |
663 | (rawOpt, Vector.length objectTypes + HashSet.size h) | |
664 | val () = | |
665 | List.push (newObjectTypes, rawTy) | |
666 | in | |
667 | {bits = width, opt = rawOpt} | |
668 | end) | |
669 | end | |
670 | ||
671 | val {get = varInfo: Var.t -> {ty: S.Type.t}, | |
672 | set = setVarInfo, ...} = | |
673 | Property.getSetOnce (Var.plist, | |
674 | Property.initRaise ("varInfo", Var.layout)) | |
675 | val setVarInfo = | |
676 | Trace.trace2 ("SsaToRssa.setVarInfo", | |
677 | Var.layout, S.Type.layout o #ty, Unit.layout) | |
678 | setVarInfo | |
679 | val varType = #ty o varInfo | |
680 | fun varOp (x: Var.t): Operand.t = | |
681 | Var {var = x, ty = valOf (toRtype (varType x))} | |
682 | val varOp = | |
683 | Trace.trace ("SsaToRssa.varOp", Var.layout, Operand.layout) varOp | |
684 | fun varOps xs = Vector.map (xs, varOp) | |
685 | val extraBlocks = ref [] | |
686 | fun newBlock {args, kind, | |
687 | statements: Statement.t vector, | |
688 | transfer: Transfer.t}: Label.t = | |
689 | let | |
690 | val l = Label.newNoname () | |
691 | val _ = List.push (extraBlocks, | |
692 | Block.T {args = args, | |
693 | kind = kind, | |
694 | label = l, | |
695 | statements = statements, | |
696 | transfer = transfer}) | |
697 | in | |
698 | l | |
699 | end | |
700 | val {get = labelInfo: (Label.t -> | |
701 | {args: (Var.t * S.Type.t) vector, | |
702 | cont: (Handler.t * Label.t) list ref, | |
703 | handler: Label.t option ref}), | |
704 | set = setLabelInfo, ...} = | |
705 | Property.getSetOnce (Label.plist, | |
706 | Property.initRaise ("label info", Label.layout)) | |
707 | fun translateCase ({test: Var.t, | |
708 | cases: S.Cases.t, | |
709 | default: Label.t option}) | |
710 | : Statement.t list * Transfer.t = | |
711 | case cases of | |
712 | S.Cases.Con cases => | |
713 | (case (Vector.length cases, default) of | |
714 | (0, NONE) => ([], Transfer.bug ()) | |
715 | | _ => | |
716 | (case S.Type.dest (varType test) of | |
717 | S.Type.Datatype tycon => | |
718 | let | |
719 | val test = fn () => varOp test | |
720 | val cases = | |
721 | Vector.map | |
722 | (cases, fn (con, dst) => | |
723 | {con = con, | |
724 | dst = dst, | |
725 | dstHasArg = | |
726 | Vector.fold | |
727 | (#args (labelInfo dst), false, fn ((_,ty),b) => | |
728 | b orelse isSome (toRtype ty))}) | |
729 | val (ss, t, blocks) = | |
730 | genCase {cases = cases, | |
731 | default = default, | |
732 | test = test, | |
733 | tycon = tycon} | |
734 | val () = | |
735 | extraBlocks := blocks @ !extraBlocks | |
736 | in | |
737 | (ss, t) | |
738 | end | |
739 | | _ => Error.bug "SsaToRssa.translateCase: strange type")) | |
740 | | S.Cases.Word (s, cases) => | |
741 | let | |
742 | val cases = | |
743 | QuickSort.sortVector | |
744 | (Vector.map (cases, fn (w, l) => (convertWordX w, l)), | |
745 | fn ((w, _), (w', _)) => WordX.le (w, w', {signed = false})) | |
746 | in | |
747 | ([], | |
748 | Switch | |
749 | (Switch.T | |
750 | {cases = cases, | |
751 | default = default, | |
752 | size = convertWordSize s, | |
753 | test = varOp test})) | |
754 | end | |
755 | fun eta (l: Label.t, kind: Kind.t): Label.t = | |
756 | let | |
757 | val {args, ...} = labelInfo l | |
758 | val args = Vector.keepAllMap (args, fn (x, t) => | |
759 | Option.map (toRtype t, fn t => | |
760 | (Var.new x, t))) | |
761 | val l' = Label.new l | |
762 | val _ = | |
763 | List.push | |
764 | (extraBlocks, | |
765 | Block.T {args = args, | |
766 | kind = kind, | |
767 | label = l', | |
768 | statements = Vector.new0 (), | |
769 | transfer = (Transfer.Goto | |
770 | {dst = l, | |
771 | args = Vector.map (args, fn (var, ty) => | |
772 | Var {var = var, | |
773 | ty = ty})})}) | |
774 | in | |
775 | l' | |
776 | end | |
777 | fun labelHandler (l: Label.t): Label.t = | |
778 | let | |
779 | val {handler, ...} = labelInfo l | |
780 | in | |
781 | case !handler of | |
782 | NONE => | |
783 | let | |
784 | val l' = eta (l, Kind.Handler) | |
785 | val _ = handler := SOME l' | |
786 | in | |
787 | l' | |
788 | end | |
789 | | SOME l => l | |
790 | end | |
791 | fun labelCont (l: Label.t, h: Handler.t): Label.t = | |
792 | let | |
793 | val {cont, ...} = labelInfo l | |
794 | datatype z = datatype Handler.t | |
795 | in | |
796 | case List.peek (!cont, fn (h', _) => Handler.equals (h, h')) of | |
797 | SOME (_, l) => l | |
798 | | NONE => | |
799 | let | |
800 | val l' = eta (l, Kind.Cont {handler = h}) | |
801 | val _ = List.push (cont, (h, l')) | |
802 | in | |
803 | l' | |
804 | end | |
805 | end | |
806 | val labelCont = | |
807 | Trace.trace2 ("SsaToRssa.labelCont", | |
808 | Label.layout, Handler.layout, Label.layout) | |
809 | labelCont | |
810 | fun vos (xs: Var.t vector) = | |
811 | Vector.keepAllMap (xs, fn x => | |
812 | Option.map (toRtype (varType x), fn _ => | |
813 | varOp x)) | |
814 | fun bogus (t: Type.t): Operand.t = | |
815 | case Type.deReal t of | |
816 | NONE => Operand.cast (Operand.word (Type.bogusWord t), t) | |
817 | | SOME s => Operand.Const (Const.real (RealX.zero s)) | |
818 | val handlesSignals = | |
819 | S.Program.hasPrim | |
820 | (program, fn p => | |
821 | case Prim.name p of | |
822 | Prim.Name.MLton_installSignalHandler => true | |
823 | | _ => false) | |
824 | fun translateFormals v = | |
825 | Vector.keepAllMap (v, fn (x, t) => | |
826 | Option.map (toRtype t, fn t => (x, t))) | |
827 | fun translatePrim p = | |
828 | Prim.map (p, fn t => | |
829 | case toRtype t of | |
830 | NONE => Type.unit | |
831 | | SOME t => t) | |
832 | fun translateTransfer (t: S.Transfer.t): (Statement.t list * | |
833 | Transfer.t) = | |
834 | case t of | |
835 | S.Transfer.Arith {args, overflow, prim, success, ty} => | |
836 | let | |
837 | val prim = translatePrim prim | |
838 | val ty = valOf (toRtype ty) | |
839 | val res = Var.newNoname () | |
840 | val noOverflow = | |
841 | newBlock | |
842 | {args = Vector.new0 (), | |
843 | kind = Kind.Jump, | |
844 | statements = Vector.new0 (), | |
845 | transfer = (Transfer.Goto | |
846 | {dst = success, | |
847 | args = (Vector.new1 | |
848 | (Var {var = res, ty = ty}))})} | |
849 | in | |
850 | if codegenImplementsPrim prim | |
851 | then ([], | |
852 | Transfer.Arith {dst = res, | |
853 | args = vos args, | |
854 | overflow = overflow, | |
855 | prim = prim, | |
856 | success = noOverflow, | |
857 | ty = ty}) | |
858 | else | |
859 | let | |
860 | datatype z = datatype Prim.Name.t | |
861 | fun doOperCheckCF (operCheck) = | |
862 | let | |
863 | val operCheckCF = | |
864 | case Name.cFunction operCheck of | |
865 | NONE => | |
866 | Error.bug | |
867 | (concat ["SsaToRssa.translateTransfer: ", | |
868 | "unimplemented arith:", | |
869 | Name.toString operCheck]) | |
870 | | SOME operCheckCF => operCheckCF | |
871 | val afterOperCheck = | |
872 | let | |
873 | val checkRes = Var.newNoname () | |
874 | in | |
875 | newBlock | |
876 | {args = Vector.new1 (checkRes, Type.bool), | |
877 | kind = Kind.CReturn {func = operCheckCF}, | |
878 | statements = Vector.new0 (), | |
879 | transfer = (Transfer.ifBool | |
880 | (Var {var = checkRes, | |
881 | ty = Type.bool}, | |
882 | {falsee = noOverflow, | |
883 | truee = overflow}))} | |
884 | end | |
885 | in | |
886 | Transfer.CCall | |
887 | {args = vos args, | |
888 | func = operCheckCF, | |
889 | return = SOME afterOperCheck} | |
890 | end | |
891 | fun doOperCF (oper, operCheck) = | |
892 | let | |
893 | val operCF = | |
894 | case Name.cFunction oper of | |
895 | NONE => | |
896 | Error.bug | |
897 | (concat ["SsaToRssa.translateTransfer: ", | |
898 | "unimplemented arith:", | |
899 | Name.toString oper]) | |
900 | | SOME operCF => operCF | |
901 | val afterOper = | |
902 | newBlock | |
903 | {args = Vector.new1 (res, ty), | |
904 | kind = Kind.CReturn {func = operCF}, | |
905 | statements = Vector.new0 (), | |
906 | transfer = doOperCheckCF operCheck} | |
907 | in | |
908 | Transfer.CCall | |
909 | {args = vos args, | |
910 | func = operCF, | |
911 | return = SOME afterOper} | |
912 | end | |
913 | fun doPrim prim = | |
914 | [Statement.PrimApp | |
915 | {dst = SOME (res, ty), | |
916 | prim = prim, | |
917 | args = vos args}] | |
918 | fun doit (prim, operCheck) = | |
919 | if codegenImplementsPrim prim | |
920 | then (doPrim prim, doOperCheckCF operCheck) | |
921 | else ([], doOperCF (Prim.name prim, operCheck)) | |
922 | in | |
923 | case Prim.name prim of | |
924 | Word_addCheck (s, sg) => | |
925 | doit (Prim.wordAdd s, | |
926 | Word_addCheck (s, sg)) | |
927 | | Word_mulCheck (s, sg) => | |
928 | doit (Prim.wordMul (s, sg), | |
929 | Word_mulCheck (s, sg)) | |
930 | | Word_negCheck s => | |
931 | doit (Prim.wordNeg s, | |
932 | Word_negCheck s) | |
933 | | Word_subCheck (s, sg) => | |
934 | doit (Prim.wordSub s, | |
935 | Word_subCheck (s, sg)) | |
936 | | _ => Error.bug (concat ["SsaToRssa.translateTransfer: ", | |
937 | "strange arith:", | |
938 | Name.toString (Prim.name prim)]) | |
939 | end | |
940 | end | |
941 | | S.Transfer.Bug => ([], Transfer.bug ()) | |
942 | | S.Transfer.Call {func, args, return} => | |
943 | let | |
944 | datatype z = datatype S.Return.t | |
945 | val return = | |
946 | case return of | |
947 | Dead => Return.Dead | |
948 | | NonTail {cont, handler} => | |
949 | let | |
950 | datatype z = datatype S.Handler.t | |
951 | val handler = | |
952 | case handler of | |
953 | Caller => Handler.Caller | |
954 | | Dead => Handler.Dead | |
955 | | Handle l => Handler.Handle (labelHandler l) | |
956 | in | |
957 | Return.NonTail {cont = labelCont (cont, handler), | |
958 | handler = handler} | |
959 | end | |
960 | | Tail => Return.Tail | |
961 | in | |
962 | ([], Transfer.Call {func = func, | |
963 | args = vos args, | |
964 | return = return}) | |
965 | end | |
966 | | S.Transfer.Case r => translateCase r | |
967 | | S.Transfer.Goto {dst, args} => | |
968 | ([], Transfer.Goto {dst = dst, args = vos args}) | |
969 | | S.Transfer.Raise xs => ([], Transfer.Raise (vos xs)) | |
970 | | S.Transfer.Return xs => ([], Transfer.Return (vos xs)) | |
971 | | S.Transfer.Runtime {args, prim, return} => | |
972 | let | |
973 | datatype z = datatype Prim.Name.t | |
974 | in | |
975 | case Prim.name prim of | |
976 | MLton_halt => | |
977 | ([], | |
978 | Transfer.CCall | |
979 | {args = Vector.concat [Vector.new1 GCState, | |
980 | vos args], | |
981 | func = CFunction.halt (), | |
982 | return = NONE}) | |
983 | | Thread_copyCurrent => | |
984 | let | |
985 | val func = CFunction.copyCurrentThread () | |
986 | val l = | |
987 | newBlock {args = Vector.new0 (), | |
988 | kind = Kind.CReturn {func = func}, | |
989 | statements = Vector.new0 (), | |
990 | transfer = (Goto {args = Vector.new0 (), | |
991 | dst = return})} | |
992 | in | |
993 | ([], | |
994 | Transfer.CCall | |
995 | {args = Vector.concat [Vector.new1 GCState, | |
996 | vos args], | |
997 | func = func, | |
998 | return = SOME l}) | |
999 | end | |
1000 | | _ => Error.bug (concat | |
1001 | ["SsaToRssa.translateTransfer: ", | |
1002 | "strange Runtime prim: ", | |
1003 | Prim.toString prim]) | |
1004 | end | |
1005 | fun translateStatementsTransfer (statements, ss, transfer) = | |
1006 | let | |
1007 | fun loop (i, ss, t): Statement.t vector * Transfer.t = | |
1008 | if i < 0 | |
1009 | then (Vector.fromList ss, t) | |
1010 | else | |
1011 | let | |
1012 | fun none () = loop (i - 1, ss, t) | |
1013 | fun add s = loop (i - 1, s :: ss, t) | |
1014 | fun add2 (s1, s2) = loop (i - 1, s1 :: s2 :: ss, t) | |
1015 | fun adds ss' = loop (i - 1, ss' @ ss, t) | |
1016 | val s = Vector.sub (statements, i) | |
1017 | in | |
1018 | case s of | |
1019 | S.Statement.Profile e => add (Statement.Profile e) | |
1020 | | S.Statement.Update {base, offset, value} => | |
1021 | (case toRtype (varType value) of | |
1022 | NONE => none () | |
1023 | | SOME t => | |
1024 | let | |
1025 | val baseOp = Base.map (base, varOp) | |
1026 | val ss = | |
1027 | update | |
1028 | {base = baseOp, | |
1029 | baseTy = varType (Base.object base), | |
1030 | offset = offset, | |
1031 | value = varOp value} | |
1032 | val ss = | |
1033 | if !Control.markCards | |
1034 | andalso Type.isObjptr t | |
1035 | then | |
1036 | updateCard (Base.object baseOp) | |
1037 | @ ss | |
1038 | else ss | |
1039 | in | |
1040 | adds ss | |
1041 | end) | |
1042 | | S.Statement.Bind {exp, ty, var} => | |
1043 | let | |
1044 | fun split (args, kind, | |
1045 | ss: Statement.t list, | |
1046 | make: Label.t -> Statement.t list * Transfer.t) = | |
1047 | let | |
1048 | val l = newBlock {args = args, | |
1049 | kind = kind, | |
1050 | statements = Vector.fromList ss, | |
1051 | transfer = t} | |
1052 | val (ss, t) = make l | |
1053 | in | |
1054 | loop (i - 1, ss, t) | |
1055 | end | |
1056 | fun maybeMove (f: Type.t -> Operand.t) = | |
1057 | case toRtype ty of | |
1058 | NONE => none () | |
1059 | | SOME ty => | |
1060 | add (Bind {dst = (valOf var, ty), | |
1061 | isMutable = false, | |
1062 | src = f ty}) | |
1063 | fun move (src: Operand.t) = maybeMove (fn _ => src) | |
1064 | in | |
1065 | case exp of | |
1066 | S.Exp.Const c => | |
1067 | (case c of | |
1068 | Const.IntInf i => | |
1069 | let | |
1070 | fun doit c = | |
1071 | maybeMove (fn ty => Operand.cast (Const c, ty)) | |
1072 | in | |
1073 | case Const.IntInfRep.fromIntInf i of | |
1074 | Const.IntInfRep.Big v => | |
1075 | doit (Const.WordVector v) | |
1076 | | Const.IntInfRep.Small w => | |
1077 | doit (Const.Word w) | |
1078 | end | |
1079 | | Const.Word w => move (Const (Const.Word (convertWordX w))) | |
1080 | | _ => move (Const c)) | |
1081 | | S.Exp.Inject {variant, ...} => | |
1082 | if isSome (toRtype ty) | |
1083 | then move (varOp variant) | |
1084 | else none () | |
1085 | | S.Exp.Object {args, con} => | |
1086 | (case toRtype ty of | |
1087 | NONE => none () | |
1088 | | SOME dstTy => | |
1089 | adds (object {args = args, | |
1090 | con = con, | |
1091 | dst = (valOf var, dstTy), | |
1092 | objectTy = ty, | |
1093 | oper = varOp})) | |
1094 | | S.Exp.PrimApp {args, prim} => | |
1095 | let | |
1096 | val prim = translatePrim prim | |
1097 | fun arg i = Vector.sub (args, i) | |
1098 | fun a i = varOp (arg i) | |
1099 | fun cast () = | |
1100 | move (Operand.cast (a 0, valOf (toRtype ty))) | |
1101 | fun ifIsWeakPointer (ty: S.Type.t, yes, no) = | |
1102 | case S.Type.dest ty of | |
1103 | S.Type.Weak ty => | |
1104 | (case toRtype ty of | |
1105 | NONE => no () | |
1106 | | SOME t => | |
1107 | if Type.isObjptr t | |
1108 | then yes t | |
1109 | else no ()) | |
1110 | | _ => Error.bug "SsaToRssa.ifIsWeakPointer" | |
1111 | fun arrayOrVectorLength () = | |
1112 | move (Offset | |
1113 | {base = a 0, | |
1114 | offset = Runtime.arrayLengthOffset (), | |
1115 | ty = Type.seqIndex ()}) | |
1116 | fun subWord s = | |
1117 | let | |
1118 | val ty = Type.word s | |
1119 | in | |
1120 | move (ArrayOffset {base = a 0, | |
1121 | index = a 1, | |
1122 | offset = Bytes.zero, | |
1123 | scale = Type.scale ty, | |
1124 | ty = ty}) | |
1125 | end | |
1126 | fun dst () = | |
1127 | case var of | |
1128 | SOME x => | |
1129 | Option.map (toRtype (varType x), fn t => | |
1130 | (x, t)) | |
1131 | | NONE => NONE | |
1132 | fun primApp prim = | |
1133 | add (PrimApp {dst = dst (), | |
1134 | prim = prim, | |
1135 | args = varOps args}) | |
1136 | datatype z = datatype Prim.Name.t | |
1137 | fun bumpAtomicState n = | |
1138 | let | |
1139 | val atomicState = Runtime GCField.AtomicState | |
1140 | val res = Var.newNoname () | |
1141 | val resTy = Operand.ty atomicState | |
1142 | in | |
1143 | [Statement.PrimApp | |
1144 | {args = (Vector.new2 | |
1145 | (atomicState, | |
1146 | (Operand.word | |
1147 | (WordX.fromIntInf | |
1148 | (IntInf.fromInt n, | |
1149 | WordSize.word32))))), | |
1150 | dst = SOME (res, resTy), | |
1151 | prim = Prim.wordAdd WordSize.word32}, | |
1152 | Statement.Move | |
1153 | {dst = atomicState, | |
1154 | src = Var {ty = resTy, var = res}}] | |
1155 | end | |
1156 | fun ccall {args: Operand.t vector, | |
1157 | func: CFunction.t} = | |
1158 | let | |
1159 | val formals = | |
1160 | case dst () of | |
1161 | NONE => Vector.new0 () | |
1162 | | SOME (x, t) => Vector.new1 (x, t) | |
1163 | in | |
1164 | split | |
1165 | (formals, Kind.CReturn {func = func}, ss, | |
1166 | fn l => | |
1167 | ([], | |
1168 | Transfer.CCall {args = args, | |
1169 | func = func, | |
1170 | return = SOME l})) | |
1171 | end | |
1172 | fun simpleCCall (f: CFunction.t) = | |
1173 | ccall {args = vos args, | |
1174 | func = f} | |
1175 | fun simpleCCallWithGCState (f: CFunction.t) = | |
1176 | ccall {args = Vector.concat | |
1177 | [Vector.new1 GCState, | |
1178 | vos args], | |
1179 | func = f} | |
1180 | fun arrayAlloc (numElts: Operand.t, opt) = | |
1181 | let | |
1182 | val result = valOf (toRtype ty) | |
1183 | val args = | |
1184 | Vector.new4 (GCState, | |
1185 | EnsuresBytesFree, | |
1186 | numElts, | |
1187 | ObjptrTycon opt) | |
1188 | val func = | |
1189 | CFunction.gcArrayAllocate | |
1190 | {return = result} | |
1191 | in | |
1192 | ccall {args = args, func = func} | |
1193 | end | |
1194 | fun cpointerGet () = | |
1195 | maybeMove (fn ty => | |
1196 | ArrayOffset {base = a 0, | |
1197 | index = a 1, | |
1198 | offset = Bytes.zero, | |
1199 | scale = Type.scale ty, | |
1200 | ty = ty}) | |
1201 | fun cpointerSet () = | |
1202 | let | |
1203 | val src = a 2 | |
1204 | val ty = Operand.ty src | |
1205 | in | |
1206 | add (Move {dst = ArrayOffset {base = a 0, | |
1207 | index = a 1, | |
1208 | offset = Bytes.zero, | |
1209 | scale = Type.scale ty, | |
1210 | ty = ty}, | |
1211 | src = a 2}) | |
1212 | end | |
1213 | fun codegenOrC (p: Prim.t) = | |
1214 | let | |
1215 | val n = Prim.name p | |
1216 | in | |
1217 | if codegenImplementsPrim p | |
1218 | then primApp p | |
1219 | else (case Name.cFunction n of | |
1220 | NONE => | |
1221 | Error.bug (concat ["SsaToRssa.codegenOrC: ", | |
1222 | "unimplemented prim:", | |
1223 | Name.toString n]) | |
1224 | | SOME f => simpleCCall f) | |
1225 | end | |
1226 | datatype z = datatype Prim.Name.t | |
1227 | in | |
1228 | case Prim.name prim of | |
1229 | Array_alloc {raw} => | |
1230 | let | |
1231 | val allocOpt = fn () => | |
1232 | let | |
1233 | val result = valOf (toRtype ty) | |
1234 | val opt = | |
1235 | case Type.deObjptr result of | |
1236 | NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_alloc" | |
1237 | | SOME opt => opt | |
1238 | in | |
1239 | opt | |
1240 | end | |
1241 | val allocRawOpt = fn () => | |
1242 | let | |
1243 | val result = valOf (toRtype ty) | |
1244 | val arrOpt = | |
1245 | case Type.deObjptr result of | |
1246 | NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_allocRaw" | |
1247 | | SOME arrOpt => arrOpt | |
1248 | val arrTy = | |
1249 | Vector.sub (objectTypes, ObjptrTycon.index arrOpt) | |
1250 | val arrElt = | |
1251 | case arrTy of | |
1252 | ObjectType.Array {elt, ...} => elt | |
1253 | | _ => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_allocRaw" | |
1254 | val rawOpt = allocRawOpt (Type.width arrElt) | |
1255 | in | |
1256 | rawOpt | |
1257 | end | |
1258 | in | |
1259 | arrayAlloc (a 0, if raw then allocRawOpt () else allocOpt ()) | |
1260 | end | |
1261 | | Array_copyArray => simpleCCallWithGCState (CFunction.gcArrayCopy (Operand.ty (a 0), Operand.ty (a 2))) | |
1262 | | Array_copyVector => simpleCCallWithGCState (CFunction.gcArrayCopy (Operand.ty (a 0), Operand.ty (a 2))) | |
1263 | | Array_length => arrayOrVectorLength () | |
1264 | | Array_toArray => | |
1265 | let | |
1266 | val rawarr = a 0 | |
1267 | val arrTy = valOf (toRtype ty) | |
1268 | val arrOpt = | |
1269 | case Type.deObjptr arrTy of | |
1270 | NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_toArray" | |
1271 | | SOME arrOpt => arrOpt | |
1272 | in | |
1273 | add2 | |
1274 | (Move | |
1275 | {dst = (Offset | |
1276 | {base = rawarr, | |
1277 | offset = Runtime.headerOffset (), | |
1278 | ty = Type.objptrHeader ()}), | |
1279 | src = ObjptrTycon arrOpt}, | |
1280 | Bind {dst = (valOf var, arrTy), | |
1281 | isMutable = false, | |
1282 | src = Operand.cast (rawarr, arrTy)}) | |
1283 | end | |
1284 | | Array_toVector => | |
1285 | let | |
1286 | val array = a 0 | |
1287 | val vecTy = valOf (toRtype ty) | |
1288 | val vecOpt = | |
1289 | case Type.deObjptr vecTy of | |
1290 | NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_toVector" | |
1291 | | SOME vecOpt => vecOpt | |
1292 | in | |
1293 | add2 | |
1294 | (Move | |
1295 | {dst = (Offset | |
1296 | {base = array, | |
1297 | offset = Runtime.headerOffset (), | |
1298 | ty = Type.objptrHeader ()}), | |
1299 | src = ObjptrTycon vecOpt}, | |
1300 | Bind {dst = (valOf var, vecTy), | |
1301 | isMutable = false, | |
1302 | src = Operand.cast (array, vecTy)}) | |
1303 | end | |
1304 | | Array_uninit => | |
1305 | let | |
1306 | val array = a 0 | |
1307 | val arrayTy = varType (arg 0) | |
1308 | val index = a 1 | |
1309 | val eltTys = | |
1310 | case S.Type.deVectorOpt arrayTy of | |
1311 | NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_uninit" | |
1312 | | SOME eltTys => eltTys | |
1313 | val sss = | |
1314 | (Vector.toList o Vector.keepAllMapi) | |
1315 | (S.Prod.dest eltTys, fn (offset, {elt, ...}) => | |
1316 | case toRtype elt of | |
1317 | NONE => NONE | |
1318 | | SOME elt => | |
1319 | if not (Type.isObjptr elt) | |
1320 | then NONE | |
1321 | else (SOME o update) | |
1322 | {base = Base.VectorSub | |
1323 | {index = index, | |
1324 | vector = array}, | |
1325 | baseTy = arrayTy, | |
1326 | offset = offset, | |
1327 | value = bogus elt}) | |
1328 | in | |
1329 | adds (List.concat sss) | |
1330 | end | |
1331 | | Array_uninitIsNop => | |
1332 | let | |
1333 | val arrayTy = varType (arg 0) | |
1334 | val eltTys = | |
1335 | case S.Type.deVectorOpt arrayTy of | |
1336 | NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_uninitIsNop" | |
1337 | | SOME eltTys => eltTys | |
1338 | val isNop = | |
1339 | Vector.forall | |
1340 | (S.Prod.dest eltTys, fn {elt, ...} => | |
1341 | case toRtype elt of | |
1342 | NONE => true | |
1343 | | SOME elt => not (Type.isObjptr elt)) | |
1344 | in | |
1345 | move (Operand.bool isNop) | |
1346 | end | |
1347 | | CPointer_getCPointer => cpointerGet () | |
1348 | | CPointer_getObjptr => cpointerGet () | |
1349 | | CPointer_getReal _ => cpointerGet () | |
1350 | | CPointer_getWord _ => cpointerGet () | |
1351 | | CPointer_setCPointer => cpointerSet () | |
1352 | | CPointer_setObjptr => cpointerSet () | |
1353 | | CPointer_setReal _ => cpointerSet () | |
1354 | | CPointer_setWord _ => cpointerSet () | |
1355 | | FFI f => simpleCCall f | |
1356 | | GC_collect => | |
1357 | ccall | |
1358 | {args = (Vector.new3 | |
1359 | (GCState, | |
1360 | Operand.zero (WordSize.csize ()), | |
1361 | Operand.bool true)), | |
1362 | func = (CFunction.gc | |
1363 | {maySwitchThreads = handlesSignals})} | |
1364 | | IntInf_add => | |
1365 | simpleCCallWithGCState | |
1366 | (CFunction.intInfBinary IntInf_add) | |
1367 | | IntInf_andb => | |
1368 | simpleCCallWithGCState | |
1369 | (CFunction.intInfBinary IntInf_andb) | |
1370 | | IntInf_arshift => | |
1371 | simpleCCallWithGCState | |
1372 | (CFunction.intInfShift IntInf_arshift) | |
1373 | | IntInf_compare => | |
1374 | simpleCCallWithGCState | |
1375 | (CFunction.intInfCompare IntInf_compare) | |
1376 | | IntInf_gcd => | |
1377 | simpleCCallWithGCState | |
1378 | (CFunction.intInfBinary IntInf_gcd) | |
1379 | | IntInf_lshift => | |
1380 | simpleCCallWithGCState | |
1381 | (CFunction.intInfShift IntInf_lshift) | |
1382 | | IntInf_mul => | |
1383 | simpleCCallWithGCState | |
1384 | (CFunction.intInfBinary IntInf_mul) | |
1385 | | IntInf_neg => | |
1386 | simpleCCallWithGCState | |
1387 | (CFunction.intInfUnary IntInf_neg) | |
1388 | | IntInf_notb => | |
1389 | simpleCCallWithGCState | |
1390 | (CFunction.intInfUnary IntInf_notb) | |
1391 | | IntInf_orb => | |
1392 | simpleCCallWithGCState | |
1393 | (CFunction.intInfBinary IntInf_orb) | |
1394 | | IntInf_quot => | |
1395 | simpleCCallWithGCState | |
1396 | (CFunction.intInfBinary IntInf_quot) | |
1397 | | IntInf_rem => | |
1398 | simpleCCallWithGCState | |
1399 | (CFunction.intInfBinary IntInf_rem) | |
1400 | | IntInf_sub => | |
1401 | simpleCCallWithGCState | |
1402 | (CFunction.intInfBinary IntInf_sub) | |
1403 | | IntInf_toString => | |
1404 | simpleCCallWithGCState | |
1405 | (CFunction.intInfToString IntInf_toString) | |
1406 | | IntInf_toVector => cast () | |
1407 | | IntInf_toWord => cast () | |
1408 | | IntInf_xorb => | |
1409 | simpleCCallWithGCState | |
1410 | (CFunction.intInfBinary IntInf_xorb) | |
1411 | | MLton_bogus => | |
1412 | (case toRtype ty of | |
1413 | NONE => none () | |
1414 | | SOME t => move (bogus t)) | |
1415 | | MLton_eq => | |
1416 | (case toRtype (varType (arg 0)) of | |
1417 | NONE => move (Operand.bool true) | |
1418 | | SOME t => | |
1419 | codegenOrC | |
1420 | (Prim.wordEqual | |
1421 | (WordSize.fromBits (Type.width t)))) | |
1422 | | MLton_installSignalHandler => none () | |
1423 | | MLton_share => | |
1424 | (case toRtype (varType (arg 0)) of | |
1425 | NONE => none () | |
1426 | | SOME t => | |
1427 | if not (Type.isObjptr t) | |
1428 | then none () | |
1429 | else | |
1430 | simpleCCallWithGCState | |
1431 | (CFunction.share (Operand.ty (a 0)))) | |
1432 | | MLton_size => | |
1433 | (case toRtype (varType (arg 0)) of | |
1434 | NONE => move (Operand.word (WordX.zero (WordSize.csize ()))) | |
1435 | | SOME t => | |
1436 | if not (Type.isObjptr t) | |
1437 | then move (Operand.word (WordX.zero (WordSize.csize ()))) | |
1438 | else | |
1439 | simpleCCallWithGCState | |
1440 | (CFunction.size (Operand.ty (a 0)))) | |
1441 | | MLton_touch => | |
1442 | let | |
1443 | val a = arg 0 | |
1444 | val args = | |
1445 | if isSome (toRtype (varType a)) | |
1446 | then Vector.new1 (varOp a) | |
1447 | else Vector.new0 () | |
1448 | in | |
1449 | add (PrimApp {args = args, | |
1450 | dst = NONE, | |
1451 | prim = prim}) | |
1452 | end | |
1453 | | Thread_atomicBegin => | |
1454 | (* gcState.atomicState++; | |
1455 | * if (gcState.signalsInfo.signalIsPending) | |
1456 | * gcState.limit = gcState.limitPlusSlop - LIMIT_SLOP; | |
1457 | *) | |
1458 | split | |
1459 | (Vector.new0 (), Kind.Jump, ss, | |
1460 | fn continue => | |
1461 | let | |
1462 | datatype z = datatype GCField.t | |
1463 | val tmp = Var.newNoname () | |
1464 | val size = WordSize.cpointer () | |
1465 | val ty = Type.cpointer () | |
1466 | val statements = | |
1467 | Vector.new2 | |
1468 | (Statement.PrimApp | |
1469 | {args = (Vector.new2 | |
1470 | (Runtime LimitPlusSlop, | |
1471 | Operand.word | |
1472 | (WordX.fromIntInf | |
1473 | (IntInf.fromInt | |
1474 | (Bytes.toInt Runtime.limitSlop), | |
1475 | size)))), | |
1476 | dst = SOME (tmp, ty), | |
1477 | prim = Prim.cpointerSub}, | |
1478 | Statement.Move | |
1479 | {dst = Runtime Limit, | |
1480 | src = Var {ty = ty, var = tmp}}) | |
1481 | val signalIsPending = | |
1482 | newBlock | |
1483 | {args = Vector.new0 (), | |
1484 | kind = Kind.Jump, | |
1485 | statements = statements, | |
1486 | transfer = (Transfer.Goto | |
1487 | {args = Vector.new0 (), | |
1488 | dst = continue})} | |
1489 | in | |
1490 | (bumpAtomicState 1, | |
1491 | if handlesSignals | |
1492 | then | |
1493 | Transfer.ifBool | |
1494 | (Runtime SignalIsPending, | |
1495 | {falsee = continue, | |
1496 | truee = signalIsPending}) | |
1497 | else | |
1498 | Transfer.Goto {args = Vector.new0 (), | |
1499 | dst = continue}) | |
1500 | end) | |
1501 | | Thread_atomicEnd => | |
1502 | (* gcState.atomicState--; | |
1503 | * if (gcState.signalsInfo.signalIsPending | |
1504 | * and 0 == gcState.atomicState) | |
1505 | * gc; | |
1506 | *) | |
1507 | split | |
1508 | (Vector.new0 (), Kind.Jump, ss, | |
1509 | fn continue => | |
1510 | let | |
1511 | datatype z = datatype GCField.t | |
1512 | val func = | |
1513 | CFunction.gc {maySwitchThreads = true} | |
1514 | val returnFromHandler = | |
1515 | newBlock | |
1516 | {args = Vector.new0 (), | |
1517 | kind = Kind.CReturn {func = func}, | |
1518 | statements = Vector.new0 (), | |
1519 | transfer = | |
1520 | Goto {args = Vector.new0 (), | |
1521 | dst = continue}} | |
1522 | val args = | |
1523 | Vector.new3 | |
1524 | (GCState, | |
1525 | Operand.zero (WordSize.csize ()), | |
1526 | Operand.bool false) | |
1527 | val switchToHandler = | |
1528 | newBlock | |
1529 | {args = Vector.new0 (), | |
1530 | kind = Kind.Jump, | |
1531 | statements = Vector.new0 (), | |
1532 | transfer = | |
1533 | Transfer.CCall | |
1534 | {args = args, | |
1535 | func = func, | |
1536 | return = SOME returnFromHandler}} | |
1537 | val testAtomicState = | |
1538 | newBlock | |
1539 | {args = Vector.new0 (), | |
1540 | kind = Kind.Jump, | |
1541 | statements = Vector.new0 (), | |
1542 | transfer = | |
1543 | Transfer.ifZero | |
1544 | (Runtime AtomicState, | |
1545 | {falsee = continue, | |
1546 | truee = switchToHandler})} | |
1547 | in | |
1548 | (bumpAtomicState ~1, | |
1549 | if handlesSignals | |
1550 | then | |
1551 | Transfer.ifBool | |
1552 | (Runtime SignalIsPending, | |
1553 | {falsee = continue, | |
1554 | truee = testAtomicState}) | |
1555 | else | |
1556 | Transfer.Goto {args = Vector.new0 (), | |
1557 | dst = continue}) | |
1558 | end) | |
1559 | | Thread_atomicState => | |
1560 | move (Runtime GCField.AtomicState) | |
1561 | | Thread_copy => | |
1562 | simpleCCallWithGCState | |
1563 | (CFunction.copyThread ()) | |
1564 | | Thread_switchTo => | |
1565 | ccall {args = (Vector.new3 | |
1566 | (GCState, | |
1567 | a 0, | |
1568 | EnsuresBytesFree)), | |
1569 | func = CFunction.threadSwitchTo ()} | |
1570 | | Vector_length => arrayOrVectorLength () | |
1571 | | Weak_canGet => | |
1572 | ifIsWeakPointer | |
1573 | (varType (arg 0), | |
1574 | fn _ => | |
1575 | simpleCCallWithGCState | |
1576 | (CFunction.weakCanGet | |
1577 | {arg = Operand.ty (a 0)}), | |
1578 | fn () => move (Operand.bool false)) | |
1579 | | Weak_get => | |
1580 | ifIsWeakPointer | |
1581 | (varType (arg 0), | |
1582 | fn t => | |
1583 | simpleCCallWithGCState | |
1584 | (CFunction.weakGet | |
1585 | {arg = Operand.ty (a 0), | |
1586 | return = t}), | |
1587 | fn () => (case toRtype ty of | |
1588 | NONE => none () | |
1589 | | SOME t => move (bogus t))) | |
1590 | | Weak_new => | |
1591 | ifIsWeakPointer | |
1592 | (ty, | |
1593 | fn t => | |
1594 | let | |
1595 | val result = valOf (toRtype ty) | |
1596 | val header = | |
1597 | ObjptrTycon | |
1598 | (case Type.deObjptr result of | |
1599 | NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Weak_new" | |
1600 | | SOME opt => opt) | |
1601 | val func = | |
1602 | CFunction.weakNew {arg = t, | |
1603 | return = result} | |
1604 | in | |
1605 | ccall {args = (Vector.concat | |
1606 | [Vector.new2 | |
1607 | (GCState, header), | |
1608 | vos args]), | |
1609 | func = func} | |
1610 | end, | |
1611 | none) | |
1612 | | Word_equal s => | |
1613 | codegenOrC (Prim.wordEqual | |
1614 | (WordSize.roundUpToPrim s)) | |
1615 | | Word_toIntInf => cast () | |
1616 | | Word_extdToWord (s1, s2, {signed}) => | |
1617 | if WordSize.equals (s1, s2) | |
1618 | then move (a 0) | |
1619 | else | |
1620 | let | |
1621 | val signed = | |
1622 | signed | |
1623 | andalso Bits.< (WordSize.bits s1, | |
1624 | WordSize.bits s2) | |
1625 | val s1 = WordSize.roundUpToPrim s1 | |
1626 | val s2 = WordSize.roundUpToPrim s2 | |
1627 | in | |
1628 | if WordSize.equals (s1, s2) | |
1629 | then cast () | |
1630 | else | |
1631 | codegenOrC | |
1632 | (Prim.wordExtdToWord | |
1633 | (s1, s2, {signed = signed})) | |
1634 | end | |
1635 | | WordVector_toIntInf => cast () | |
1636 | | WordArray_subWord {eleSize, ...} => | |
1637 | subWord eleSize | |
1638 | | WordArray_updateWord {eleSize, ...} => | |
1639 | let | |
1640 | val ty = Type.word eleSize | |
1641 | in | |
1642 | add (Move {dst = (ArrayOffset | |
1643 | {base = a 0, | |
1644 | index = a 1, | |
1645 | offset = Bytes.zero, | |
1646 | scale = Type.scale ty, | |
1647 | ty = ty}), | |
1648 | src = a 2}) | |
1649 | end | |
1650 | | WordVector_subWord {eleSize, ...} => | |
1651 | subWord eleSize | |
1652 | | World_save => | |
1653 | simpleCCallWithGCState | |
1654 | (CFunction.worldSave ()) | |
1655 | | _ => codegenOrC prim | |
1656 | end | |
1657 | | S.Exp.Select {base, offset} => | |
1658 | (case var of | |
1659 | NONE => none () | |
1660 | | SOME var => | |
1661 | (case toRtype ty of | |
1662 | NONE => none () | |
1663 | | SOME ty => | |
1664 | adds | |
1665 | (select | |
1666 | {base = Base.map (base, varOp), | |
1667 | baseTy = varType (Base.object base), | |
1668 | dst = (var, ty), | |
1669 | offset = offset}))) | |
1670 | | S.Exp.Var y => | |
1671 | (case toRtype ty of | |
1672 | NONE => none () | |
1673 | | SOME _ => move (varOp y)) | |
1674 | end | |
1675 | end | |
1676 | in | |
1677 | loop (Vector.length statements - 1, ss, transfer) | |
1678 | end | |
1679 | fun translateBlock (S.Block.T {label, args, statements, transfer}) = | |
1680 | let | |
1681 | val (ss, t) = translateTransfer transfer | |
1682 | val (ss, t) = translateStatementsTransfer (statements, ss, t) | |
1683 | in | |
1684 | Block.T {args = translateFormals args, | |
1685 | kind = Kind.Jump, | |
1686 | label = label, | |
1687 | statements = ss, | |
1688 | transfer = t} | |
1689 | end | |
1690 | fun translateFunction (f: S.Function.t): Function.t = | |
1691 | let | |
1692 | val _ = | |
1693 | S.Function.foreachVar (f, fn (x, t) => setVarInfo (x, {ty = t})) | |
1694 | val {args, blocks, name, raises, returns, start, ...} = | |
1695 | S.Function.dest f | |
1696 | val _ = | |
1697 | Vector.foreach | |
1698 | (blocks, fn S.Block.T {label, args, ...} => | |
1699 | setLabelInfo (label, {args = args, | |
1700 | cont = ref [], | |
1701 | handler = ref NONE})) | |
1702 | val blocks = Vector.map (blocks, translateBlock) | |
1703 | val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks] | |
1704 | val _ = extraBlocks := [] | |
1705 | fun transTypes (ts : S.Type.t vector option) | |
1706 | : Type.t vector option = | |
1707 | Option.map (ts, fn ts => Vector.keepAllMap (ts, toRtype)) | |
1708 | in | |
1709 | Function.new {args = translateFormals args, | |
1710 | blocks = blocks, | |
1711 | name = name, | |
1712 | raises = transTypes raises, | |
1713 | returns = transTypes returns, | |
1714 | start = start} | |
1715 | end | |
1716 | val main = | |
1717 | let | |
1718 | val start = Label.newNoname () | |
1719 | val bug = Label.newNoname () | |
1720 | in | |
1721 | translateFunction | |
1722 | (S.Function.profile | |
1723 | (S.Function.new | |
1724 | {args = Vector.new0 (), | |
1725 | blocks = (Vector.new2 | |
1726 | (S.Block.T | |
1727 | {label = start, | |
1728 | args = Vector.new0 (), | |
1729 | statements = globals, | |
1730 | transfer = (S.Transfer.Call | |
1731 | {args = Vector.new0 (), | |
1732 | func = main, | |
1733 | return = | |
1734 | S.Return.NonTail | |
1735 | {cont = bug, | |
1736 | handler = S.Handler.Dead}})}, | |
1737 | S.Block.T | |
1738 | {label = bug, | |
1739 | args = Vector.new0 (), | |
1740 | statements = Vector.new0 (), | |
1741 | transfer = S.Transfer.Bug})), | |
1742 | mayInline = false, (* doesn't matter *) | |
1743 | name = Func.newNoname (), | |
1744 | raises = NONE, | |
1745 | returns = NONE, | |
1746 | start = start}, | |
1747 | S.SourceInfo.main)) | |
1748 | end | |
1749 | val functions = List.revMap (functions, translateFunction) | |
1750 | val p = Program.T {functions = functions, | |
1751 | handlesSignals = handlesSignals, | |
1752 | main = main, | |
1753 | objectTypes = Vector.concat [objectTypes, Vector.fromListRev (!newObjectTypes)]} | |
1754 | val _ = Program.clear p | |
1755 | in | |
1756 | p | |
1757 | end | |
1758 | ||
1759 | end |