Self-compile and mlton.cm
Stephen Weeks
MLton@sourcelight.com
Wed, 11 Oct 2000 17:53:57 -0700 (PDT)
> Anyways, this should be an easy one to find, if not fix. I'll send mail
> shortly.
There was a bug in backend.fun. Here is a new version. I didn't finish testing
it yet, but I'm pretty sure it'll get the bug. I'll let you know when I finish
testing, but it may not be until tomorrow.
--------------------------------------------------------------------------------
(* Copyright (C) 1997-1999 NEC Research Institute.
* Please see the file LICENSE for license information.
*)
functor Backend(S: BACKEND_STRUCTS): BACKEND =
struct
open S
local open Cps
in
structure Cases = Cases
structure Con = Con
structure Const = Const
structure Cdec = Dec
structure Cexp = Exp
structure Func = Func
structure Function = Function
structure Cprogram = Program
structure CPrimInfo = PrimInfo
structure Ctype = Type
structure Jump = Jump
structure Prim = Prim
structure PrimExp = PrimExp
structure Tycon = Tycon
structure Ctransfer = Transfer
structure Var = Var
end
local open Machine
in
structure Chunk = Chunk
structure GCInfo = GCInfo
structure Label = Label
structure MlimitCheck = LimitCheck
structure Mtype = Type
structure Mprogram = Program
structure Operand = Operand
structure MPrimInfo = PrimInfo
structure Register = Register
structure Statement = Statement
structure Mtransfer = Transfer
structure MOtransfer = MachineOutput.Transfer
end
structure Chunkify = Chunkify(open Cps)
structure ParallelMove = ParallelMove()
structure Representation = Representation(structure Cps = Cps
structure Mtype = Mtype)
structure AllocateRegisters = AllocateRegisters(structure Cps = Cps
structure Machine = Machine)
local open AllocateRegisters
in structure Info = Info
end
local open Representation
in structure TyconRep = TyconRep
structure ConRep = ConRep
end
fun generate(program as Cprogram.T{datatypes, globals, functions, main})
: Mprogram.t =
let
val {tyconRep, conRep, toMtype} =
Control.traceCall "compute representations"
Representation.compute program
val _ =
Control.displays
("rep", fn display =>
List.foreach
(datatypes, fn {tycon, cons} =>
let open Layout
in display(seq[Tycon.layout tycon,
str " ",
TyconRep.layout(tyconRep tycon)])
; display(indent(align(List.map(cons, fn {con, ...} =>
seq[Con.layout con,
str " ",
ConRep.layout(conRep con)])),
2))
end))
fun toMtypes ts = List.map(ts, toMtype)
val wordSize = 4
val tagOffset = 0
val tagType = Mtype.int
val jumpHandlers = Cps.inferHandlers program
val chunks =
Control.traceCall "chunkify" Chunkify.chunkify
{program = program,
jumpHandlers = jumpHandlers}
val _ =
Control.displays
("chunks", fn display =>
List.foreach
(chunks, fn {funcs, jumps} =>
let open Layout
in display
(record([("funcs", List.layout Func.layout funcs),
("jumps", List.layout Jump.layout jumps)]))
end))
val {get = jumpInfo: Jump.t -> {args: (Var.t * Ctype.t) list,
chunk: Chunk.t option ref,
cont: Label.t option ref,
handler: Label.t option ref},
set = setJumpInfo} =
Property.new(Jump.plist, Property.initRaise("jump info", Jump.layout))
val jumpArgs = #args o jumpInfo
val jumpChunk = valOf o ! o #chunk o jumpInfo
val jumpCont = valOf o ! o #cont o jumpInfo
val jumpHandler = valOf o ! o #handler o jumpInfo
val {get = funcInfo: Func.t -> {chunk: Chunk.t},
set = setFuncInfo} =
Property.new(Func.plist, Property.initRaise("func info", Func.layout))
val funcChunk = #chunk o funcInfo
val funcChunkLabel = Chunk.label o funcChunk
val mprogram = Mprogram.new()
val raiseGlobal: Operand.t option ref = ref NONE
fun raiseOperand(): Operand.t =
case !raiseGlobal of
NONE => Error.bug "raiseGlobal not defined"
| SOME z => z
(* Create info for jumps used as conts. *)
val _ =
let
fun new(j: Jump.t, sel) =
sel(jumpInfo j) := SOME(Label.new(jumpToLabel j))
fun loopExp(e: Cexp.t): unit =
let val {decs, transfer} = Cexp.dest e
in List.foreach(decs, loopDec)
; (case transfer of
Ctransfer.Call{cont, ...} =>
Option.app(cont, fn c => new(c, #cont))
| _ => ())
end
and loopDec(d: Cdec.t): unit =
case d of
Cdec.Fun{name, args, body} =>
(setJumpInfo(name, {args = args,
chunk = ref NONE,
cont = ref NONE,
handler = ref NONE})
; loopExp body)
| Cdec.HandlerPush h =>
(case !raiseGlobal of
SOME _ => ()
| NONE =>
(case jumpArgs h of
[(_, t)] =>
let
val t = toMtype t
val oper =
if Mtype.isPointer t
then
Mprogram.newGlobalPointerNonRoot
mprogram
else Mprogram.newGlobal(mprogram, t)
in raiseGlobal := SOME oper
end
| _ => Error.bug "handler with <> 1 arg")
; new(h, #handler))
| _ => ()
val _ = List.foreach(functions, loopExp o #body)
in ()
end
val machineChunks = ref []
(* Create the mprogram chunks. *)
val _ =
List.foreach
(chunks, fn {funcs, jumps} =>
let
val conts =
List.fold(jumps, [], fn (j, cs) =>
let
val {handler, cont, ...} = jumpInfo j
fun add(r, cs) =
case !r of
NONE => cs
| SOME l => l :: cs
in add(handler, add(cont, cs))
end)
val c = Mprogram.newChunk{program = mprogram,
entries =
List.map(funcs, funcToLabel) @ conts}
in List.push(machineChunks, c)
; List.foreach(funcs, fn f => setFuncInfo(f, {chunk = c}))
; List.foreach(jumps, fn j => #chunk(jumpInfo j) := SOME c)
end)
val {get = varInfo: Var.t -> {ty: Ctype.t,
operand: Operand.t option ref,
isConstant: bool ref},
set = setVarInfo} =
Property.new(Var.plist, Property.initRaise("info", Var.layout))
val varIsConstant = ! o #isConstant o varInfo
val varType = #ty o varInfo
val varOperand = ! o #operand o varInfo
val varOperand =
Trace.trace("varOperand", Var.layout, Option.layout Operand.layout)
varOperand
val setVarOperand =
fn (x, p) =>
let val {operand, ...} = varInfo x
in case !operand of
NONE => operand := SOME p
| SOME _ => Error.bug("setVarOperand twice of " ^ Var.toString x)
end
val setVarOperand =
Trace.trace2("setVarOperand", Var.layout, Operand.layout, Unit.layout)
setVarOperand
val _ =
let
val set = fn (x, t) => setVarInfo(x, {ty = t,
operand = ref NONE,
isConstant = ref false})
fun sets xts = List.foreach(xts, set)
val _ =
List.foreach(globals, fn {var, ty, ...} => set(var, ty))
fun loopExp e = List.foreach(#decs(Cexp.dest e), loopDec)
and loopDec d =
case d of
Cdec.Bind{var, ty, ...} => set(var, ty)
| Cdec.Fun{args, body, ...} => (sets args; loopExp body)
| _ => ()
in List.foreach(functions, fn {name, args, body, ...} =>
(sets args; loopExp body))
end
fun varTypes xs = List.map(xs, varType)
val varMtype = toMtype o varType
fun varMtypes xs = List.map(xs, varMtype)
fun sortTypes(initialOffset: int,
tys: Mtype.t list): {size: int,
offsets: int list,
numWordsNonPointers: int,
numPointers: int} =
let
val voids = ref []
val bytes = ref []
val doubleWords = ref []
val words = ref []
val pointers = ref []
val _ = List.foreachi(tys, fn (i, t) =>
List.push
(if Mtype.isPointer t
then pointers
else (case Mtype.size t of
0 => voids
| 1 => bytes
| 4 => words
| 8 => doubleWords
| _ => Error.bug "strange size"),
(i, t)))
fun build(r, accum) =
List.fold(!r, accum, fn ((index, ty), (res, offset)) =>
({index = index, offset = offset, ty = ty} :: res,
offset + Mtype.size ty))
val (accum, offset) =
build
(voids,
build(bytes,
build(words,
build(doubleWords, ([], initialOffset)))))
val offset = Mtype.align(offset, Mtype.pointer)
val numWordsNonPointers = (offset - initialOffset) div wordSize
val (accum, size) = build(pointers, (accum, offset))
val components = List.rev accum
fun loop(i, accum) =
if i = ~1
then accum
else loop(i - 1,
#offset(List.lookup(components, fn {index, ...} =>
i = index))
:: accum)
val offsets = loop(List.length components - 1, [])
in {size = size,
offsets = offsets,
numWordsNonPointers = numWordsNonPointers,
numPointers = List.length(!pointers)}
end
(* Compute layout for each con and associate it with the con.
*)
local
val {get, set} =
Property.new(Con.plist, Property.initRaise("con info", Con.layout))
in
val _ =
List.foreach
(datatypes, fn {cons, ...} =>
List.foreach(cons, fn {con, args} =>
let
fun doit n =
let val mtypes = toMtypes args
in set(con, {info = sortTypes(n, mtypes),
mtypes = mtypes})
end
in case conRep con of
ConRep.Tuple => doit 0
| ConRep.TagTuple _ => doit 4
| _ => ()
end))
val conInfo = get
end
(* Compute layout for each tuple type.
*)
local
val {get, set} =
Property.new
(Ctype.plist,
Property.initFun(fn t => sortTypes(0, toMtypes(Ctype.detuple t))))
in
val tupleInfo = get
fun tupleOffset(t: Ctype.t, n: int): int =
List.nth(#offsets(get t), n)
end
fun parallelMove{srcs, dsts, chunk} =
let
val moves =
List.map2(srcs, dsts, fn (src, dst) => {src = src, dst = dst})
fun temp r =
Operand.register(Chunk.tempRegister(chunk, Operand.ty r))
(* val temp =
* Trace.trace("temp", Operand.layout, Operand.layout) temp
*)
in
(* Trace.trace
* ("parallelMove",
* fn {moves, ...} =>
* List.layout (fn {src, dst} =>
* Layout.tuple
* [Operand.layout src, Operand.layout dst])
* moves,
* Layout.ignore)
*)
ParallelMove.move{
equals = Operand.equals,
move = Statement.move,
moves = moves,
interfere = Operand.interfere,
temp = temp
}
end
fun genConstBind{var, ty, exp} =
let
fun set(oper: Operand.t): unit =
let val {operand, isConstant, ...} = varInfo var
in operand := SOME oper
; isConstant := true
end
fun global(new, s) = set(new(mprogram, s))
fun constant(new, s) = set(new(mprogram, s))
fun bogus() = set Operand.void
fun nonExpansive() =
if Mtype.isVoid(toMtype ty)
then bogus()
else ()
in case exp of
PrimExp.ConApp{con, args} =>
(case conRep con of
ConRep.Void => bogus()
| ConRep.Int n => set(Operand.int n)
| ConRep.IntCast n => set(Operand.pointer n)
| _ => ())
| PrimExp.Const c =>
(case Const.node c of
Const.Int n =>
(Assert.assert("genConstBind Const", fn () =>
Tycon.equals(Const.tycon c, Tycon.int))
; set(Operand.int n))
| Const.Word w =>
set
(let val t = Const.tycon c
in if Tycon.equals(t, Tycon.word)
then Operand.uint w
else if Tycon.equals(t, Tycon.word8)
then Operand.char(Char.chr(Word.toInt w))
else Error.bug "strange word"
end)
| Const.Real f => if !Control.globalFloats
then global(Mprogram.newFloat, f)
else set(Operand.float f)
| Const.Char c => set(Operand.char c)
| Const.String s => global(Mprogram.newString, s)
| Const.SmallIntInf i => set(Operand.intInf i)
| Const.IntInf s => global(Mprogram.newIntInf, s))
| PrimExp.PrimApp{prim, ...} =>
(case Prim.name prim of
Prim.Name.MLton_bogus =>
set(case Mtype.dest(toMtype ty) of
Mtype.Char => Operand.char #"\000"
(* | Mtype.Double => Operand.float "0.0" *)
| Mtype.Int => Operand.int 0
| Mtype.Uint => Operand.uint 0w0
| Mtype.Pointer => Operand.pointer 1
| _ => Error.bug "bogus not implemented for type")
| _ => ())
| PrimExp.Select _ => nonExpansive()
| PrimExp.Tuple [] => bogus()
| PrimExp.Tuple _ => ()
| PrimExp.Var x =>
(case varOperand x of
NONE => ()
| SOME oper => set oper)
end
(* val genConstBind =
* Trace.trace("genConstBind", Var.layout o #var, Unit.layout)
* genConstBind
*)
(* Set the operands for constants.
* This has to happen before register allocation so that RA doesn't
* allocate registers for them.
*)
val _ =
(List.foreach(globals, genConstBind)
; (List.foreach
(globals, fn {var, ty, exp} =>
case varOperand var of
NONE =>
setVarOperand
(var,
case exp of
PrimExp.Var x =>
(case varOperand x of
NONE => Error.bug "global missing operand"
| SOME oper => oper)
| _ => Mprogram.newGlobal(mprogram, toMtype ty))
| SOME _ => ()))
; List.foreach(functions, fn {body, ...} =>
Cexp.foreachBind(body, genConstBind)))
val varIsUsed = Cps.Program.varIsUsed program
fun shouldAllocate x =
varIsUsed x andalso not(Option.isSome(varOperand x))
val {contInfo, funcInfo = funcRegInfo, handlerInfo,
jumpInfo = jumpRegInfo, maxFrameSize, primInfo} =
Control.pass
{name = "allocate registers",
suffix = "reg",
style = Control.No,
thunk = fn () =>
AllocateRegisters.allocate
{
funcChunk = funcChunk,
jumpChunk = jumpChunk,
jumpHandlers = jumpHandlers,
program = program,
shouldAllocate = shouldAllocate,
varType = varMtype
},
display =
Control.Layouts
(fn ({funcInfo, jumpInfo, ...}, layout) =>
let
val constantVarOperand = varOperand
open Layout
fun layoutVar varOperand x =
layout(seq[Var.layout x, str " ",
if varIsUsed x
then Operand.layout(case constantVarOperand x of
NONE => varOperand x
| SOME z => z)
else str "unused"])
fun loopBind varOperand {var, ty, exp} = layoutVar varOperand var
fun loop(Info.T{varOperand, ...}, args, body) =
let val layoutVar = layoutVar varOperand
val loopBind = loopBind varOperand
in List.foreach(args, layoutVar o #1)
; (List.foreach
(#decs(Cexp.dest body),
fn Cdec.Bind b => loopBind b
| Cdec.Fun{name, args, body} =>
loop(jumpInfo name, args, body)
| _ => ()))
end
in List.foreach(globals, loopBind(valOf o varOperand))
; (List.foreach
(functions, fn {name, args, body, ...} =>
let val {info, handlerOffset, ...} = funcInfo name
in layout(seq[str "function ", Func.layout name,
str " handlerOffset ",
Option.layout Int.layout handlerOffset])
; loop(#info(funcInfo name), args, body)
end))
end)}
val _ = Mprogram.setMaxFrameSize(mprogram, maxFrameSize)
local
fun make sel (j: Jump.t) =
let val Info.T r = jumpRegInfo j
in sel r
end
in
val jumpLive = make #live
val jumpLiveNoFormals = make #liveNoFormals
end
fun tail'(to: Jump.t, srcs: Operand.t list)
: Statement.t list * Mtransfer.t * bool =
let val t = Mtransfer.nearJump {label = jumpToLabel to}
in case srcs of
[] => ([], t, false)
| _ =>
let
val Info.T{varOperand, ...} = jumpRegInfo to
val (srcs, dsts) =
List.fold2
(srcs, jumpArgs to, ([], []),
fn (src, (x, _), ac as (srcs, dsts)) =>
if varIsUsed x
then (src :: srcs, varOperand x :: dsts)
else ac)
in (parallelMove{srcs = srcs,
dsts = dsts,
chunk = jumpChunk to},
t,
length srcs > 0)
end
end
fun tail(to: Jump.t, srcs: Operand.t list) =
let val (s, t, _) = tail'(to, srcs)
in (s, t)
end
fun conSelects(variant: Operand.t, con: Con.t): Operand.t list =
let
val _ = Assert.assert("conSelects", fn () =>
case conRep con of
ConRep.TagTuple _ => true
| ConRep.Tuple => true
| _ => false)
val {info = {offsets, ...}, mtypes} = conInfo con
in List.map2(offsets, mtypes, fn (i, t) =>
Operand.offset{base = variant,
offset = i,
ty = t})
end
fun maybeAddReg(rs: Register.t list,
oper: Operand.t): Register.t list =
case Operand.deRegister oper of
NONE => rs
| SOME r => r :: rs
(* ------------------------------------------------- *)
(* genCase *)
(* ------------------------------------------------- *)
fun genCase{chunk: Chunk.t,
profileName: string,
test: Operand.t,
testRep: TyconRep.t,
cases: (Con.t * Jump.t) list,
default: Jump.t option} =
let
(* Creating this new block without limit checks is OK because all
* it does is a few moves and then a transfer. I.E. it does no
* allocations and can not trigger a GC.
*)
fun newBlock(live, statements, transfer): Label.t =
let val l = Label.newNoname()
in Chunk.newBlock(chunk,
{label = l,
profileName = profileName,
live = live,
statements = statements,
transfer = transfer})
; l
end
fun switch{test, testReg, cases, default, live, numLeft}
: {live: Register.t list, transfer: Mtransfer.t} =
let
val (live, default) =
if 0 = numLeft
then (live, NONE)
else (case default of
NONE => (live, NONE)
| SOME j =>
(jumpLive j @ live, SOME(jumpToLabel j)))
val transfer =
Mtransfer.switch
{test = test, cases = cases, default = default}
val live =
if Mtransfer.isSwitch transfer
then maybeAddReg(live, testReg)
else live
in {live = live,
transfer = transfer}
end
fun enum(test: Operand.t, testReg: Operand.t, numEnum: int) =
let
val (live, cases, numLeft) =
List.fold
(cases, ([], [], numEnum),
fn ((c, j), (regs, cases, numLeft)) =>
let
fun keep n =
(jumpLiveNoFormals j @ regs,
(n, jumpToLabel j) :: cases,
numLeft - 1)
in case conRep c of
ConRep.Int n => keep n
| ConRep.IntCast n => keep n
| _ => (regs, cases, numLeft)
end)
in switch{test = test, testReg = testReg,
cases = cases, default = default,
live = live, numLeft = numLeft}
end
fun transferToLabel{live, transfer}: Label.t =
case Mtransfer.toMOut transfer of
MOtransfer.NearJump{label, ...} => label
| _ => newBlock(live, [], transfer)
fun switchIP(numEnum, pointer: Label.t): Mtransfer.t =
let
val int =
transferToLabel(enum(Operand.castInt test, test, numEnum))
in Mtransfer.switchIP{test = test,
int = int,
pointer = pointer}
end
fun doTail(j: Jump.t, args: Operand.t list)
: Register.t list * Label.t =
let val (s, t, testIsUsed) = tail'(j, args)
in case (s, Mtransfer.toMOut t) of
([], MOtransfer.NearJump{label}) => (jumpLive j, label)
| _ => let val live = jumpLiveNoFormals j
val live =
if testIsUsed
then maybeAddReg(live, test)
else live
in (live, newBlock(live, s, t))
end
end
fun enumAndOne(numEnum: int): Mtransfer.t =
let
val rec loop =
fn [] =>
(case default of
NONE => Error.bug "enumAndOne: no default"
| SOME j => (j, []))
| (c, j) :: cases =>
(case conRep c of
ConRep.Transparent _ => (j, [test])
| ConRep.Tuple => (j, conSelects(test, c))
| _ => loop cases)
in switchIP(numEnum, #2(doTail(loop cases)))
end
fun indirectTag(numTag: int) =
let
val (live, cases, numLeft) =
List.fold
(cases, ([], [], numTag),
fn ((c, j), (live, cases, numLeft)) =>
case conRep c of
ConRep.TagTuple n =>
let val (live', l) = doTail(j, conSelects(test, c))
in (live' @ live, (n, l) :: cases, numLeft - 1)
end
| _ => (live, cases, numLeft))
in switch{test = Operand.offset{base = test,
offset = tagOffset,
ty = tagType},
testReg = test,
cases = cases, default = default,
live = live, numLeft = numLeft}
end
in case testRep of
TyconRep.Prim mtype =>
(case (cases, default) of
([(c, l)], _) =>
(* We use _ instead of NONE for the default becuase
* there may be an unreachable default case
*)
(case conRep c of
ConRep.Void => tail(l, [])
| ConRep.Transparent _ => tail(l, [test])
| ConRep.Tuple => tail(l, conSelects(test, c))
| _ => Error.bug "strange conRep for Prim")
| ([], SOME j) => tail(j, [])
| _ => Error.bug "prim datatype with more than one case")
| TyconRep.Enum{numEnum} => ([], #transfer(enum(test, test, numEnum)))
| TyconRep.EnumDirect{numEnum} => ([], enumAndOne numEnum)
| TyconRep.EnumIndirect{numEnum} => ([], enumAndOne numEnum)
| TyconRep.EnumIndirectTag{numEnum, numTag} =>
([], switchIP(numEnum, transferToLabel(indirectTag numTag)))
| TyconRep.IndirectTag{numTag} => ([], #transfer(indirectTag numTag))
end
(* ------------------------------------------------- *)
(* genPrimExp *)
(* ------------------------------------------------- *)
fun genPrimExp(x: Var.t, ty: Ctype.t, e: PrimExp.t,
chunk: Chunk.t,
varOperand,
handlers: Jump.t list): Statement.t list =
if varIsConstant x
orelse (not(varIsUsed x) andalso not(PrimExp.maySideEffect e))
then []
else
let
fun varOperands xs = List.map(xs, varOperand)
fun move src =
if varIsUsed x
then [Statement.move{dst = varOperand x, src = src}]
else []
fun makeStores(ys, offsets) =
List.fold2(ys, offsets, [], fn (y, offset, stores) =>
if Mtype.isVoid(Operand.ty y)
then stores
else {offset = offset, value = y} :: stores)
fun allocate(ys, {size, offsets,
numPointers, numWordsNonPointers}) =
if varIsUsed x
then [Statement.allocate
{dst = varOperand x,
size = size,
numPointers = numPointers,
numWordsNonPointers = numWordsNonPointers,
stores = makeStores(ys, offsets)}]
else []
fun allocateTagged(n: int, ys: Operand.t list,
{size, offsets,
numPointers, numWordsNonPointers}) =
if varIsUsed x
then
[Statement.allocate
{dst = varOperand x,
size = size,
numPointers = numPointers,
numWordsNonPointers =
(* for the tag *) 1 + numWordsNonPointers,
stores = ({offset = tagOffset, value = Operand.int n}
:: makeStores(ys, offsets))}]
else []
in case e of
PrimExp.ConApp{con, args} =>
let val args = varOperands args
fun tuple() = allocate(args, #info(conInfo con))
in case (conRep con, args) of
(ConRep.Transparent _, [y]) => move y
| (ConRep.Tuple, _) => tuple()
| (ConRep.TagTuple n, _) =>
allocateTagged(n, args, #info(conInfo con))
| _ => Error.bug "strange ConApp"
end
| PrimExp.PrimApp{prim, info, targs, args} =>
let
fun offset(a, i, ty) =
Operand.arrayOffset{base = a,
offset = i,
ty = ty}
fun unsafeSub(a, i, ty) = move(offset(a, i, toMtype ty))
fun array(n: Operand.t, t: Mtype.t): Statement.t list =
if not(varIsUsed x)
then []
else
let
val (nbnp, np) =
if Mtype.isPointer t
then (0, 1)
else (Mtype.size t, 0)
in [Statement.allocateArray
{dst = varOperand x,
numElts = n,
numBytesNonPointers = nbnp,
numPointers = np,
gcInfo = primInfo x}]
end
val argOps = varOperands args
datatype z = datatype Prim.Name.t
in case (Prim.name prim, targs, argOps) of
(Array_array, [t], [n]) => array(n, toMtype t)
| (Array_sub, [t], [a, i]) => unsafeSub(a, i, t)
| (Array_update, [t], [a, i, y]) =>
let val t = toMtype t
in case Mtype.dest t of
Mtype.Void => []
| _ => [Statement.move{dst = offset(a, i, t), src = y}]
end
| (String_sub, [], [s, i]) => unsafeSub(s, i, Ctype.char)
| (Ref_assign, [t], [y, z]) =>
let val t = toMtype t
in case Mtype.dest t of
Mtype.Void => []
| _ => [Statement.move{dst = Operand.contents(y, t),
src = z}]
end
| (Ref_deref, [t], [y]) =>
let val t = toMtype t
in case Mtype.dest t of
Mtype.Void => []
| _ => move(Operand.contents(y, t))
end
| (Ref_ref, [t], [y]) =>
let val t = toMtype t
val (ys, ts) = if Mtype.isVoid t
then ([], [])
else ([y], [t])
in allocate(ys, sortTypes(0, ts))
end
| (Vector_fromArray, _, [src]) => move src
| (Vector_sub, [t], [v, i]) => unsafeSub(v, i, t)
| _ =>
let
val pinfo =
case info of
CPrimInfo.None => MPrimInfo.None
| CPrimInfo.Overflow l =>
MPrimInfo.Overflow(jumpToLabel l)
in
[Statement.assign
{dst = if (Mtype.isVoid(toMtype ty)
orelse not(varIsUsed x))
then NONE
else SOME(varOperand x),
oper = prim,
args = argOps,
pinfo = pinfo,
info = if Prim.entersRuntime prim
then SOME(primInfo x)
else NONE}]
end
end
| PrimExp.Select{tuple, offset} =>
if Mtype.isVoid(Operand.ty(varOperand x))
then []
else
move(Operand.offset
{base = varOperand tuple,
offset = tupleOffset(varType tuple, offset),
ty = toMtype ty})
| PrimExp.Tuple ys => allocate(varOperands ys, tupleInfo ty)
| PrimExp.Var y => move(varOperand y)
| _ => Error.bug "genPrimExp saw strange primExp"
end
val genPrimExp =
Trace.trace("genPrimExp",
fn (x, t, e, _, _, _) => Layout.tuple[Var.layout x,
Ctype.layout t,
PrimExp.layout e],
Layout.ignore)
genPrimExp
fun varsRegs(xs: Var.t list, varOperand): Register.t list =
List.fold(xs, [], fn (x, rs) =>
case Operand.deRegister(varOperand x) of
NONE => rs
| SOME r => r :: rs)
(* ------------------------------------------------- *)
(* genCont *)
(* ------------------------------------------------- *)
fun genCont (c: Chunk.t,
l: Label.t,
j: Jump.t,
args: (Var.t * Ctype.t) list,
profileName: string): unit =
let
val {size, liveOffsets} = contInfo j
val _ = Mprogram.newFrame(mprogram,
{return = l,
chunkLabel = Chunk.label c,
size = size,
liveOffsets = liveOffsets})
val (offset, offsets, args) =
List.fold
(args, (4, liveOffsets, []),
fn ((_, ty), (offset, offsets, args)) =>
let
val ty = toMtype ty
val offset = Mtype.align(offset, ty)
val calleeOffset = offset + size
val arg = Operand.stackOffset{offset = calleeOffset,
ty = ty}
val offsets =
if Mtype.isPointer ty
then calleeOffset :: offsets
else offsets
in (offset + Mtype.size ty,
offsets,
arg :: args)
end)
val args = rev args
val limitCheck =
MlimitCheck.Maybe(GCInfo.make{frameSize = size + offset,
offsets = offsets})
val (statements, transfer) = tail(j, args)
val chunk = jumpChunk j
val statements =
Statement.pop size
:: Statement.limitCheck limitCheck
:: statements
val _ =
Chunk.newBlock
(chunk, {label = l,
live = [],
profileName = profileName,
statements = statements,
transfer = transfer})
in ()
end
(* ------------------------------------------------- *)
(* genHandler *)
(* ------------------------------------------------- *)
fun genHandler (c: Chunk.t,
l: Label.t,
j: Jump.t,
args: (Var.t * Ctype.t) list,
profileName: string): unit =
let
val _ = Mprogram.newHandler(mprogram, {chunkLabel = Chunk.label c,
label = l})
val {size, liveOffsets} = handlerInfo j
val args = [raiseOperand()]
val (statements, transfer) = tail(j, args)
(* restore stack pointer *)
val statements = Statement.pop size :: statements
in Chunk.newBlock(jumpChunk j,
{label = l,
live = [],
profileName = profileName,
statements = statements,
transfer = transfer})
end
(* ------------------------------------------------- *)
(* genTransfer *)
(* ------------------------------------------------- *)
fun genTransfer(t: Ctransfer.t,
chunk: Chunk.t,
profileName: string,
varOperand,
handlers: Jump.t list): Statement.t list * Mtransfer.t =
case t of
Ctransfer.Bug => ([], Mtransfer.bug)
| Ctransfer.Call{func, args, cont} =>
let val args = List.map(args, varOperand)
val offsets =
rev(#2(List.fold
(args, (4, []), (* 4 is for return address *)
fn (arg, (offset, offsets)) =>
let val ty = Operand.ty arg
val offset = Mtype.align(offset, ty)
in (offset + Mtype.size ty,
offset :: offsets)
end)))
val (frameSize, changeFrame) =
case cont of
NONE => (0, [])
| SOME c =>
let val {size, liveOffsets} = contInfo c
in (size,
[Statement.push size,
Statement.move
{dst = Operand.stackOffset{offset = 0,
ty = Mtype.int},
src = Operand.label(jumpCont c)}])
end
val setupArgs =
let
val moves =
List.map2
(args, offsets, fn (arg, offset) =>
{src = arg,
dst = (Operand.stackOffset
{offset = frameSize + offset,
ty = Operand.ty arg})})
fun temp r =
Operand.register
(Chunk.tempRegister(chunk, Operand.ty r))
in
(* Trace.trace
* ("parallelMove",
* fn {moves, ...} =>
* List.layout (fn {src, dst} =>
* Layout.tuple
* [Operand.layout src, Operand.layout dst])
* moves,
* fn ss => (List.foreach(ss, fn s =>
* (Statement.output(s, print)
* ; print "\n"))
* ; Layout.empty))
*)
ParallelMove.move{equals = Operand.equals,
move = Statement.move,
moves = moves,
interfere = Operand.interfere,
temp = temp}
end
val chunk' = funcChunk func
val func = funcToLabel func
val transfer =
if Chunk.equals(chunk, chunk')
then Mtransfer.nearJump {label = func}
else Mtransfer.farJump {chunkLabel = Chunk.label chunk',
label = func}
in (setupArgs @ changeFrame, transfer)
end
| Ctransfer.Case{test, cases = Cases.Int cases, default, ...} =>
([],
Mtransfer.switch
{test = varOperand test,
cases = List.revMap(cases, fn (i, j) => (i, jumpToLabel j)),
default = Option.map(default, jumpToLabel)})
| Ctransfer.Case{test, cases = Cases.Con cases, default, ...} =>
(case (cases, default) of
([], NONE) => ([], Mtransfer.bug)
| _ =>
case Ctype.tyconArgs(varType test) of
(tycon, []) =>
genCase{cases = cases,
chunk = chunk,
default = default,
profileName = profileName,
test = varOperand test,
testRep = tyconRep tycon}
| _ => Error.bug "strange type in case")
| Ctransfer.Jump{dst, args} => tail(dst, List.map(args, varOperand))
| Ctransfer.Raise xs =>
let val xops = List.map(xs, varOperand)
in case handlers of
[] => (Statement.moves{dsts = [raiseOperand()],
srcs = xops},
Mtransfer.raisee)
| h :: _ => tail(h, xops)
end
| Ctransfer.Return xs =>
let val rets = List.map(xs, varOperand)
val offsets
= rev(#2(List.fold(rets,
(4, []),
fn (ret, (offset, offsets)) =>
let
val ty = Operand.ty ret
val offset = Mtype.align(offset, ty)
in
(offset + Mtype.size ty,
offset :: offsets)
end)))
val moves
= List.map2(rets, offsets,
fn (ret, offset) =>
{src = ret,
dst = (Operand.stackOffset
{offset = offset,
ty = Operand.ty ret})})
fun temp r =
Operand.register
(Chunk.tempRegister(chunk, Operand.ty r))
in
(ParallelMove.move{equals = Operand.equals,
move = Statement.move,
moves = moves,
interfere = Operand.interfere,
temp = temp},
Mtransfer.return)
end
val genTransfer =
Trace.trace("genTransfer", Ctransfer.layout o #1, Layout.ignore)
genTransfer
(*------------------------------------*)
(* genExp *)
(*------------------------------------*)
fun genExp{exp = e: Cexp.t,
profileName: string,
label: Label.t,
chunk: Chunk.t,
info = Info.T{limitCheck, live, prelude, postlude,
varOperand = vo, ...},
handlerOffset: int option,
handlers: Jump.t list}: unit =
let
val {decs, transfer} = Cexp.dest e
val varOperand = (fn x =>
case varOperand x of
SOME p => p
| NONE => vo x)
val (decs, handlers) =
genDecs(decs, chunk, profileName, varOperand, handlers,
handlerOffset)
val (preTransfer, transfer) =
genTransfer(transfer, chunk, profileName, varOperand, handlers)
val statements =
Statement.limitCheck limitCheck
:: List.flatten[prelude, decs, postlude, preTransfer]
in
Chunk.newBlock
(chunk, {label = label,
live = live,
profileName = profileName,
statements = statements,
transfer = transfer})
end
and genDecs(ds: Cdec.t list,
chunk: Chunk.t,
profileName: string,
varOperand,
handlers: Jump.t list,
handlerOffset): Statement.t list * Jump.t list =
let
val (statements, handlers) =
List.fold
(ds, ([], handlers), fn (d , (statements, handlers)) =>
(case d of
Cdec.Bind{var, ty, exp} =>
genPrimExp(var, ty, exp, chunk, varOperand, handlers)
:: statements
| Cdec.Fun{name, args, body} =>
let
val {chunk, cont, handler, ...} = jumpInfo name
val chunk = valOf(!chunk)
val _ =
case !cont of
NONE => ()
| SOME l =>
genCont(chunk, l, name, args, profileName)
val _ =
case !handler of
NONE => ()
| SOME l =>
genHandler(chunk, l, name, args, profileName)
val _ =
genExp{exp = body,
profileName = profileName,
label = jumpToLabel name,
chunk = chunk,
info = jumpRegInfo name,
handlerOffset = handlerOffset,
handlers = jumpHandlers name}
in statements
end
| Cdec.HandlerPush h =>
let
val offset = valOf handlerOffset
val statements =
[Statement.move
{dst = Operand.stackOffset{offset = offset,
ty = Mtype.label},
src = Operand.label(jumpHandler h)}]
:: statements
in case handlers of
[] => ([Statement.saveExnStack{offset = offset}]
:: statements)
| _ => statements
end
| Cdec.HandlerPop =>
let val offset = valOf handlerOffset
in case handlers of
[] => Error.bug "pop of empty handler stack"
| _ :: handlers =>
(case handlers of
[] =>
[Statement.restoreExnStack{offset = offset}]
| h :: _ =>
[Statement.move
{dst =
Operand.stackOffset{offset = offset,
ty = Mtype.label},
src = Operand.label(jumpHandler h)}])
:: statements
end,
Cps.deltaHandlers(d, handlers)))
in (List.fold(statements, [], op @), handlers)
end
(* Build the initGlobals chunk. *)
val initGlobals = Label.newString "initGlobals"
val chunk = Mprogram.newChunk{program = mprogram,
entries = [initGlobals]}
val initGlobalsStatements =
Statement.limitCheck(MlimitCheck.Maybe
(GCInfo.make{offsets = [],
frameSize = Mtype.size Mtype.label}))
::
List.fold
(List.fold(globals, [], fn ({var, ty, exp}, statements) =>
(genPrimExp(var, ty, exp, chunk, valOf o varOperand, [])
:: statements)),
[], op @)
in Mprogram.setMain(mprogram, {chunkLabel = Chunk.label chunk,
label = initGlobals})
; (Chunk.newBlock
(chunk, {label = initGlobals,
live = [],
profileName = "initGlobals",
statements = initGlobalsStatements,
transfer = Mtransfer.farJump {chunkLabel = funcChunkLabel main,
label = funcToLabel main}}))
; (List.foreach
(functions, fn {name, body, ...} =>
let val {info, handlerOffset, ...} = funcRegInfo name
in genExp{exp = body,
profileName = Func.toString name,
label = funcToLabel name,
chunk = funcChunk name,
info = info,
handlerOffset = handlerOffset,
handlers = []}
end))
; Cprogram.clear program
; mprogram
end
end