HCoop / hcoop / debian / mlton.git / blame
| 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 |