Permalink
Fetching contributors…
Cannot retrieve contributors at this time
939 lines (870 sloc) 32.9 KB
(* Copyright (C) 2011,2014-2015,2017 Matthew Fluet.
* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a HPND-style license.
* See the file MLton-LICENSE for details.
*)
functor Compile (S: COMPILE_STRUCTS): COMPILE =
struct
open S
(*---------------------------------------------------*)
(* Intermediate Languages *)
(*---------------------------------------------------*)
structure Atoms = Atoms ()
local
open Atoms
in
structure Const = Const
structure ConstType = Const.ConstType
structure Ffi = Ffi
structure Symbol = Symbol
structure WordSize = WordSize
structure WordX = WordX
end
structure Ast = Ast (open Atoms)
structure TypeEnv = TypeEnv (open Atoms)
structure CoreML = CoreML (open Atoms
structure Type =
struct
open TypeEnv.Type
val makeHom =
fn {con, var} =>
makeHom {con = con,
expandOpaque = true,
var = var}
fun layout t =
#1 (layoutPretty
(t, {expandOpaque = true,
layoutPrettyTycon = Tycon.layout,
layoutPrettyTyvar = Tyvar.layout}))
end)
structure Xml = Xml (open Atoms)
structure Sxml = Sxml (open Xml)
structure ParseSxml = ParseSxml(structure XmlTree = Xml)
structure Ssa = Ssa (open Atoms)
structure ParseSsa = ParseSsa(structure SsaTree = Ssa)
structure Ssa2 = Ssa2 (open Atoms)
structure ParseSsa2 = ParseSsa2(structure SsaTree2 = Ssa2)
structure Machine = Machine (open Atoms
structure Label = Ssa.Label)
local
open Machine
in
structure Runtime = Runtime
end
(*---------------------------------------------------*)
(* Compiler Passes *)
(*---------------------------------------------------*)
structure FrontEnd = FrontEnd (structure Ast = Ast)
structure MLBFrontEnd = MLBFrontEnd (structure Ast = Ast
structure FrontEnd = FrontEnd)
structure DeadCode = DeadCode (structure CoreML = CoreML)
structure Defunctorize = Defunctorize (structure CoreML = CoreML
structure Xml = Xml)
structure Elaborate = Elaborate (structure Ast = Ast
structure CoreML = CoreML
structure TypeEnv = TypeEnv)
local
open Elaborate
in
structure Env = Env
end
structure LookupConstant = LookupConstant (structure Const = Const
structure ConstType = ConstType
structure Ffi = Ffi)
structure Monomorphise = Monomorphise (structure Xml = Xml
structure Sxml = Sxml)
structure ClosureConvert = ClosureConvert (structure Ssa = Ssa
structure Sxml = Sxml)
structure SsaToSsa2 = SsaToSsa2 (structure Ssa = Ssa
structure Ssa2 = Ssa2)
structure Backend = Backend (structure Ssa = Ssa2
structure Machine = Machine
fun funcToLabel f = f)
structure CCodegen = CCodegen (structure Ffi = Ffi
structure Machine = Machine)
structure LLVMCodegen = LLVMCodegen (structure CCodegen = CCodegen
structure Machine = Machine)
structure x86Codegen = x86Codegen (structure CCodegen = CCodegen
structure Machine = Machine)
structure amd64Codegen = amd64Codegen (structure CCodegen = CCodegen
structure Machine = Machine)
(* ------------------------------------------------- *)
(* Lookup Constant *)
(* ------------------------------------------------- *)
val commandLineConstants: {name: string, value: string} list ref = ref []
fun setCommandLineConstant (c as {name, value}) =
let
fun make (fromString, control) =
let
fun set () =
case fromString value of
NONE => Error.bug (concat ["bad value for ", name])
| SOME v => control := v
in
set
end
val () =
case List.peek ([("Exn.keepHistory",
make (Bool.fromString, Control.exnHistory))],
fn (s, _) => s = name) of
NONE => ()
| SOME (_,set) => set ()
in
List.push (commandLineConstants, c)
end
val allConstants: (string * ConstType.t) list ref = ref []
val amBuildingConstants: bool ref = ref false
val lookupConstant =
let
val zero = Const.word (WordX.fromIntInf (0, WordSize.word32))
val f =
Promise.lazy
(fn () =>
if !amBuildingConstants
then (fn ({name, default, ...}, t) =>
let
(* Don't keep constants that already have a default value.
* These are defined by _command_line_const and set by
* -const, and shouldn't be looked up.
*)
val () =
if isSome default
then ()
else List.push (allConstants, (name, t))
in
zero
end)
else
File.withIn
(concat [!Control.libTargetDir, "/constants"], fn ins =>
LookupConstant.load (ins, !commandLineConstants)))
in
fn z => f () z
end
(* ------------------------------------------------- *)
(* Primitive Env *)
(* ------------------------------------------------- *)
local
structure Con = TypeEnv.Con
structure Tycon = TypeEnv.Tycon
structure Type = TypeEnv.Type
structure Tyvar =
struct
open TypeEnv.Tyvar
open TypeEnv.TyvarExt
end
val primitiveDatatypes =
Vector.new3
({tycon = Tycon.bool,
tyvars = Vector.new0 (),
cons = Vector.new2 ({con = Con.falsee, arg = NONE},
{con = Con.truee, arg = NONE})},
let
val a = Tyvar.makeNoname {equality = false}
in
{tycon = Tycon.list,
tyvars = Vector.new1 a,
cons = Vector.new2 ({con = Con.nill, arg = NONE},
{con = Con.cons,
arg = SOME (Type.tuple
(Vector.new2
(Type.var a,
Type.list (Type.var a))))})}
end,
let
val a = Tyvar.makeNoname {equality = false}
in
{tycon = Tycon.reff,
tyvars = Vector.new1 a,
cons = Vector.new1 {con = Con.reff, arg = SOME (Type.var a)}}
end)
val primitiveExcons =
let
open CoreML.Con
in
[bind, match, overflow]
end
structure Con =
struct
open Con
fun toAst c =
Ast.Con.fromSymbol (Symbol.fromString (Con.toString c),
Region.bogus)
end
structure Env =
struct
open Env
structure Tycon =
struct
open Tycon
fun toAst c =
Ast.Tycon.fromSymbol (Symbol.fromString (Tycon.toString c),
Region.bogus)
end
structure Type = TypeEnv.Type
structure Scheme = TypeEnv.Scheme
fun addPrim (E: t): unit =
let
val _ =
List.foreach
(Tycon.prims, fn {name, tycon, ...} =>
if List.contains ([Tycon.arrow, Tycon.tuple], tycon, Tycon.equals)
then ()
else extendTycon
(E, Ast.Tycon.fromSymbol (Symbol.fromString name,
Region.bogus),
TypeStr.tycon tycon,
{forceUsed = false, isRebind = false}))
val _ =
Vector.foreach
(primitiveDatatypes, fn {tyvars, tycon, cons} =>
let
val cons =
Vector.map
(cons, fn {con, arg} =>
let
val res =
Type.con (tycon, Vector.map (tyvars, Type.var))
val ty =
case arg of
NONE => res
| SOME arg => Type.arrow (arg, res)
val scheme =
Scheme.make
{canGeneralize = true,
ty = ty,
tyvars = tyvars}
in
{con = con,
name = Con.toAst con,
scheme = scheme}
end)
val cons = Env.newCons (E, cons)
in
extendTycon
(E, Tycon.toAst tycon,
TypeStr.data (tycon, cons),
{forceUsed = false, isRebind = false})
end)
val _ =
extendTycon (E,
Ast.Tycon.fromSymbol (Symbol.unit, Region.bogus),
TypeStr.def (Scheme.fromType Type.unit),
{forceUsed = false, isRebind = false})
val scheme = Scheme.fromType Type.exn
val _ = List.foreach (primitiveExcons, fn c =>
extendExn (E, Con.toAst c, c, scheme))
in
()
end
end
val primitiveDecs: CoreML.Dec.t list =
let
open CoreML.Dec
in
List.concat [[Datatype primitiveDatatypes],
List.map
(primitiveExcons, fn c =>
Exception {con = c, arg = NONE})]
end
in
fun addPrim E =
(Env.addPrim E
; primitiveDecs)
end
(* ------------------------------------------------- *)
(* parseAndElaborateMLB *)
(* ------------------------------------------------- *)
fun quoteFile s = concat ["\"", String.escapeSML s, "\""]
structure MLBString:>
sig
type t
val fromFile: File.t -> t
val fromString: string -> t
val lexAndParseMLB: t -> Ast.Basdec.t
end =
struct
type t = string
val fromFile = quoteFile
val fromString = fn s => s
val lexAndParseMLB = MLBFrontEnd.lexAndParseString
end
val lexAndParseMLB = MLBString.lexAndParseMLB
val lexAndParseMLB: MLBString.t -> Ast.Basdec.t =
fn input =>
let
val ast = lexAndParseMLB input
val _ = Control.checkForErrors "parse"
in
ast
end
fun sourceFilesMLB {input} =
Ast.Basdec.sourceFiles (lexAndParseMLB (MLBString.fromFile input))
val elaborateMLB = Elaborate.elaborateMLB
val displayEnvDecs =
Control.Layouts
(fn ((_, decs),output) =>
(output (Layout.str "\n\n")
; Vector.foreach
(decs, fn (dec, dc) =>
(output o Layout.record)
[("deadCode", Bool.layout dc),
("decs", List.layout CoreML.Dec.layout dec)])))
fun parseAndElaborateMLB (input: MLBString.t)
: Env.t * (CoreML.Dec.t list * bool) vector =
Control.pass
{display = displayEnvDecs,
name = "parseAndElaborate",
stats = fn _ => Layout.empty,
style = Control.ML,
suffix = "core-ml",
thunk = (fn () =>
(if !Control.keepAST
then File.remove (concat [!Control.inputFile, ".ast"])
else ()
; Const.lookup := lookupConstant
; elaborateMLB (lexAndParseMLB input, {addPrim = addPrim})))}
(* ------------------------------------------------- *)
(* Basis Library *)
(* ------------------------------------------------- *)
fun outputBasisConstants (out: Out.t): unit =
let
val _ = amBuildingConstants := true
val (_, decs) =
parseAndElaborateMLB (MLBString.fromFile "$(SML_LIB)/basis/primitive/primitive.mlb")
val decs = Vector.concatV (Vector.map (decs, Vector.fromList o #1))
(* Need to defunctorize so the constants are forced. *)
val _ = Defunctorize.defunctorize (CoreML.Program.T {decs = decs})
val _ = LookupConstant.build (!allConstants, out)
in
()
end
(* ------------------------------------------------- *)
(* compile *)
(* ------------------------------------------------- *)
exception Done
fun elaborate {input: MLBString.t}: Xml.Program.t =
let
val (E, decs) = parseAndElaborateMLB input
val _ =
case !Control.showBasis of
NONE => ()
| SOME f =>
File.withOut
(f, fn out =>
Env.output
(E, out,
{compact = !Control.showBasisCompact,
def = !Control.showBasisDef,
flat = !Control.showBasisFlat,
onlyCurrent = false,
prefixUnset = true}))
val _ = Env.processDefUse E
val _ =
case !Control.exportHeader of
NONE => ()
| SOME f =>
File.withOut
(f, fn out =>
let
fun print s = Out.output (out, s)
val libname = !Control.libname
val libcap = CharVector.map Char.toUpper libname
val _ = print ("#ifndef __" ^ libcap ^ "_ML_H__\n")
val _ = print ("#define __" ^ libcap ^ "_ML_H__\n")
val _ = print "\n"
val _ =
File.outputContents
(concat [!Control.libDir, "/include/ml-types.h"], out)
val _ = print "\n"
val _ =
File.outputContents
(concat [!Control.libDir, "/include/export.h"], out)
val _ = print "\n"
(* How do programs link against this library by default *)
val defaultLinkage =
case !Control.format of
Control.Archive => "STATIC_LINK"
| Control.Executable => "PART_OF"
| Control.LibArchive => "NO_DEFAULT_LINK"
| Control.Library => "DYNAMIC_LINK"
val _ =
print ("#if !defined(PART_OF_" ^ libcap ^ ") && \\\n\
\ !defined(STATIC_LINK_" ^ libcap ^ ") && \\\n\
\ !defined(DYNAMIC_LINK_" ^ libcap ^ ")\n")
val _ =
print ("#define " ^ defaultLinkage ^ "_" ^ libcap ^ "\n")
val _ = print "#endif\n"
val _ = print "\n"
val _ = print ("#if defined(PART_OF_" ^ libcap ^ ")\n")
val _ = print "#define MLLIB_PRIVATE(x) PRIVATE x\n"
val _ = print "#define MLLIB_PUBLIC(x) PUBLIC x\n"
val _ = print ("#elif defined(STATIC_LINK_" ^ libcap ^ ")\n")
val _ = print "#define MLLIB_PRIVATE(x)\n"
val _ = print "#define MLLIB_PUBLIC(x) PUBLIC x\n"
val _ = print ("#elif defined(DYNAMIC_LINK_" ^ libcap ^ ")\n")
val _ = print "#define MLLIB_PRIVATE(x)\n"
val _ = print "#define MLLIB_PUBLIC(x) EXTERNAL x\n"
val _ = print "#else\n"
val _ = print ("#error Must specify linkage for " ^ libname ^ "\n")
val _ = print "#define MLLIB_PRIVATE(x)\n"
val _ = print "#define MLLIB_PUBLIC(x)\n"
val _ = print "#endif\n"
val _ = print "\n"
val _ = print "#ifdef __cplusplus\n"
val _ = print "extern \"C\" {\n"
val _ = print "#endif\n"
val _ = print "\n"
val _ =
if !Control.format = Control.Executable then () else
(print ("MLLIB_PUBLIC(void " ^ libname ^ "_open(int argc, const char** argv);)\n")
;print ("MLLIB_PUBLIC(void " ^ libname ^ "_close();)\n"))
val _ = Ffi.declareHeaders {print = print}
val _ = print "\n"
val _ = print "#undef MLLIB_PRIVATE\n"
val _ = print "#undef MLLIB_PUBLIC\n"
val _ = print "\n"
val _ = print "#ifdef __cplusplus\n"
val _ = print "}\n"
val _ = print "#endif\n"
val _ = print "\n"
val _ = print ("#endif /* __" ^ libcap ^ "_ML_H__ */\n")
in
()
end)
val _ = if !Control.elaborateOnly then raise Done else ()
val decs =
Control.pass
{display = Control.Layouts (fn (decss,output) =>
(output (Layout.str "\n\n")
; Vector.foreach (decss, fn decs =>
List.foreach (decs, fn dec =>
output (CoreML.Dec.layout dec))))),
name = "deadCode",
suffix = "core-ml",
style = Control.ML,
stats = fn _ => Layout.empty,
thunk = fn () => let
val {prog = decs} =
DeadCode.deadCode {prog = decs}
in
decs
end}
val decs = Vector.concatV (Vector.map (decs, Vector.fromList))
val coreML = CoreML.Program.T {decs = decs}
val _ =
let
open Control
in
if !keepCoreML
then saveToFile ({suffix = "core-ml"}, No, coreML,
Layouts CoreML.Program.layouts)
else ()
end
val xml =
Control.passTypeCheck
{display = Control.Layouts Xml.Program.layouts,
name = "defunctorize",
stats = Xml.Program.layoutStats,
style = Control.ML,
suffix = "xml",
thunk = fn () => Defunctorize.defunctorize coreML,
typeCheck = Xml.typeCheck}
in
xml
end
fun simplifyXml xml =
let val xml =
Control.passTypeCheck
{display = Control.Layouts Xml.Program.layouts,
name = "xmlSimplify",
stats = Xml.Program.layoutStats,
style = Control.ML,
suffix = "xml",
thunk = fn () => Xml.simplify xml,
typeCheck = Xml.typeCheck}
open Control
val _ =
if !keepXML
then saveToFile ({suffix = "xml"}, No, xml,
Layouts Xml.Program.layouts)
else ()
in
xml
end
fun makeSxml xml =
Control.passTypeCheck
{display = Control.Layouts Sxml.Program.layouts,
name = "monomorphise",
stats = Sxml.Program.layoutStats,
style = Control.ML,
suffix = "sxml",
thunk = fn () => Monomorphise.monomorphise xml,
typeCheck = Sxml.typeCheck}
fun simplifySxml sxml =
let
val sxml =
Control.passTypeCheck
{display = Control.Layouts Sxml.Program.layouts,
name = "sxmlSimplify",
stats = Sxml.Program.layoutStats,
style = Control.ML,
suffix = "sxml",
thunk = fn () => Sxml.simplify sxml,
typeCheck = Sxml.typeCheck}
open Control
val _ =
if !keepSXML
then saveToFile ({suffix = "sxml"}, No, sxml,
Layouts Sxml.Program.layouts)
else ()
in
sxml
end
fun makeSsa sxml =
Control.passTypeCheck
{display = Control.Layouts Ssa.Program.layouts,
name = "closureConvert",
stats = Ssa.Program.layoutStats,
style = Control.ML,
suffix = "ssa",
thunk = fn () => ClosureConvert.closureConvert sxml,
typeCheck = Ssa.typeCheck}
fun simplifySsa ssa =
let
val ssa =
Control.passTypeCheck
{display = Control.Layouts Ssa.Program.layouts,
name = "ssaSimplify",
stats = Ssa.Program.layoutStats,
style = Control.ML,
suffix = "ssa",
thunk = fn () => Ssa.simplify ssa,
typeCheck = Ssa.typeCheck}
open Control
val _ =
if !keepSSA
then saveToFile ({suffix = "ssa"}, No, ssa,
Layouts Ssa.Program.layouts)
else ()
in
ssa
end
fun makeSsa2 ssa =
Control.passTypeCheck
{display = Control.Layouts Ssa2.Program.layouts,
name = "toSsa2",
stats = Ssa2.Program.layoutStats,
style = Control.ML,
suffix = "ssa2",
thunk = fn () => SsaToSsa2.convert ssa,
typeCheck = Ssa2.typeCheck}
fun simplifySsa2 ssa2 =
let
val ssa2 =
Control.passTypeCheck
{display = Control.Layouts Ssa2.Program.layouts,
name = "ssa2Simplify",
stats = Ssa2.Program.layoutStats,
style = Control.ML,
suffix = "ssa2",
thunk = fn () => Ssa2.simplify ssa2,
typeCheck = Ssa2.typeCheck}
open Control
val _ =
if !keepSSA2
then saveToFile ({suffix = "ssa2"}, ML, ssa2,
Layouts Ssa2.Program.layouts)
else ()
in
ssa2
end
fun makeMachine ssa2 =
let
val codegenImplementsPrim =
case !Control.codegen of
Control.AMD64Codegen => amd64Codegen.implementsPrim
| Control.CCodegen => CCodegen.implementsPrim
| Control.LLVMCodegen => LLVMCodegen.implementsPrim
| Control.X86Codegen => x86Codegen.implementsPrim
val machine =
Control.passTypeCheck
{display = Control.Layouts Machine.Program.layouts,
name = "backend",
stats = fn _ => Layout.empty,
style = Control.No,
suffix = "machine",
thunk = fn () =>
(Backend.toMachine
(ssa2,
{codegenImplementsPrim = codegenImplementsPrim})),
typeCheck = fn machine =>
(* For now, machine type check is too slow to run. *)
(if !Control.typeCheck
then Machine.Program.typeCheck machine
else ())}
val _ =
let
open Control
in
if !keepMachine
then saveToFile ({suffix = "machine"}, No, machine,
Layouts Machine.Program.layouts)
else ()
end
in
machine
end
fun setupConstants() : unit =
(* Set GC_state offsets and sizes. *)
let
val _ =
let
fun get (name: string): Bytes.t =
case lookupConstant ({default = NONE, name = name},
ConstType.Word WordSize.word32) of
Const.Word w => Bytes.fromInt (WordX.toInt w)
| _ => Error.bug "Compile.setupConstants: GC_state offset must be an int"
in
Runtime.GCField.setOffsets
{
atomicState = get "atomicState_Offset",
cardMapAbsolute = get "generationalMaps.cardMapAbsolute_Offset",
currentThread = get "currentThread_Offset",
curSourceSeqsIndex = get "sourceMaps.curSourceSeqsIndex_Offset",
exnStack = get "exnStack_Offset",
frontier = get "frontier_Offset",
limit = get "limit_Offset",
limitPlusSlop = get "limitPlusSlop_Offset",
maxFrameSize = get "maxFrameSize_Offset",
signalIsPending = get "signalsInfo.signalIsPending_Offset",
stackBottom = get "stackBottom_Offset",
stackLimit = get "stackLimit_Offset",
stackTop = get "stackTop_Offset"
};
Runtime.GCField.setSizes
{
atomicState = get "atomicState_Size",
cardMapAbsolute = get "generationalMaps.cardMapAbsolute_Size",
currentThread = get "currentThread_Size",
curSourceSeqsIndex = get "sourceMaps.curSourceSeqsIndex_Size",
exnStack = get "exnStack_Size",
frontier = get "frontier_Size",
limit = get "limit_Size",
limitPlusSlop = get "limitPlusSlop_Size",
maxFrameSize = get "maxFrameSize_Size",
signalIsPending = get "signalsInfo.signalIsPending_Size",
stackBottom = get "stackBottom_Size",
stackLimit = get "stackLimit_Size",
stackTop = get "stackTop_Size"
}
end
(* Setup endianness *)
val _ =
let
fun get (name:string): bool =
case lookupConstant ({default = NONE, name = name},
ConstType.Bool) of
Const.Word w => 1 = WordX.toInt w
| _ => Error.bug "Compile.setupConstants: endian unknown"
in
Control.Target.setBigEndian (get "MLton_Platform_Arch_bigendian")
end
in
()
end
fun preCodegen (input: MLBString.t): Machine.Program.t =
let
val xml = elaborate {input = input}
val _ = setupConstants ()
val xml = simplifyXml xml
val sxml = makeSxml xml
val sxml = simplifySxml sxml
val ssa = makeSsa sxml
val ssa = simplifySsa ssa
val ssa2 = makeSsa2 ssa
val ssa2 = simplifySsa2 ssa2
in
makeMachine ssa2
end
fun compile {input: 'a, resolve: 'a -> Machine.Program.t, outputC, outputLL, outputS}: unit =
let
val machine =
Control.trace (Control.Top, "pre codegen")
resolve input
fun clearNames () =
(Machine.Program.clearLabelNames machine
; Machine.Label.printNameAlphaNumeric := true)
val () =
case !Control.codegen of
Control.AMD64Codegen =>
(clearNames ()
; (Control.trace (Control.Top, "amd64 code gen")
amd64Codegen.output {program = machine,
outputC = outputC,
outputS = outputS}))
| Control.CCodegen =>
(clearNames ()
; (Control.trace (Control.Top, "C code gen")
CCodegen.output {program = machine,
outputC = outputC}))
| Control.LLVMCodegen =>
(clearNames ()
; (Control.trace (Control.Top, "llvm code gen")
LLVMCodegen.output {program = machine,
outputC = outputC,
outputLL = outputLL}))
| Control.X86Codegen =>
(clearNames ()
; (Control.trace (Control.Top, "x86 code gen")
x86Codegen.output {program = machine,
outputC = outputC,
outputS = outputS}))
val _ = Control.message (Control.Detail, PropertyList.stats)
val _ = Control.message (Control.Detail, HashSet.stats)
in
()
end handle Done => ()
fun compileMLB {input: File.t, outputC, outputLL, outputS}: unit =
compile {input = MLBString.fromFile input,
resolve = preCodegen,
outputC = outputC,
outputLL = outputLL,
outputS = outputS}
val elaborateMLB =
fn {input: File.t} =>
(ignore (elaborate {input = MLBString.fromFile input}))
handle Done => ()
local
fun genMLB {input: File.t list}: MLBString.t =
let
val basis = "$(SML_LIB)/basis/default.mlb"
in
MLBString.fromString
(case input of
[] => basis
| _ =>
let
val input = List.map (input, quoteFile)
in
String.concat
["local\n",
basis, "\n",
"in\n",
String.concat (List.separate (input, "\n")), "\n",
"end\n"]
end)
end
in
fun compileSML {input: File.t list, outputC, outputLL, outputS}: unit =
compile {input = genMLB {input = input},
resolve = preCodegen,
outputC = outputC,
outputLL = outputLL,
outputS = outputS}
val elaborateSML =
fn {input: File.t list} =>
(ignore (elaborate {input = genMLB {input = input}}))
handle Done => ()
end
fun genFromSXML (input: File.t): Machine.Program.t =
let
val _ = setupConstants()
val sxml =
Control.passTypeCheck
{display = Control.Layouts Sxml.Program.layouts,
name = "sxmlParse",
stats = Sxml.Program.layoutStats,
style = Control.ML,
suffix = "sxml",
thunk = (fn () => case
Parse.parseFile(ParseSxml.program, input)
of Result.Yes x => x
| Result.No msg => (Control.error
(Region.bogus, Layout.str "Sxml Parse failed", Layout.str msg);
Control.checkForErrors("parse");
(* can't be reached *)
raise Fail "parse")
),
typeCheck = Sxml.typeCheck}
val sxml = simplifySxml sxml
val ssa = makeSsa sxml
val ssa = simplifySsa ssa
val ssa2 = makeSsa2 ssa
val ssa2 = simplifySsa2 ssa2
in
makeMachine ssa2
end
fun compileSXML {input: File.t, outputC, outputLL, outputS}: unit =
compile {input = input,
resolve = genFromSXML,
outputC = outputC,
outputLL = outputLL,
outputS = outputS}
fun genFromSsa (input: File.t): Machine.Program.t =
let
val _ = setupConstants()
val ssa =
Control.passTypeCheck
{display = Control.Layouts Ssa.Program.layouts,
name = "ssaParse",
stats = Ssa.Program.layoutStats,
style = Control.ML,
suffix = "ssa",
thunk = (fn () => case
Parse.parseFile(ParseSsa.program, input)
of Result.Yes x => x
| Result.No msg => (Control.error
(Region.bogus, Layout.str "Ssa Parse failed", Layout.str msg);
Control.checkForErrors("parse");
(* can't be reached *)
raise Fail "parse")
),
typeCheck = Ssa.typeCheck}
val ssa = simplifySsa ssa
val ssa2 = makeSsa2 ssa
val ssa2 = simplifySsa2 ssa2
in
makeMachine ssa2
end
fun compileSSA {input: File.t, outputC, outputLL, outputS}: unit =
compile {input = input,
resolve = genFromSsa,
outputC = outputC,
outputLL = outputLL,
outputS = outputS}
fun genFromSsa2 (input: File.t): Machine.Program.t =
let
val _ = setupConstants()
val ssa2 =
Control.passTypeCheck
{display = Control.Layouts Ssa2.Program.layouts,
name = "ssa2Parse",
stats = Ssa2.Program.layoutStats,
style = Control.ML,
suffix = "ssa2",
thunk = (fn () => case
Parse.parseFile(ParseSsa2.program, input)
of Result.Yes x => x
| Result.No msg => (Control.error
(Region.bogus, Layout.str "Ssa2 Parse failed", Layout.str msg);
Control.checkForErrors("parse");
(* can't be reached *)
raise Fail "parse")
),
typeCheck = Ssa2.typeCheck}
(*val ssa2 = makeSsa2 ssa*)
val ssa2 = simplifySsa2 ssa2
in
makeMachine ssa2
end
fun compileSSA2 {input: File.t, outputC, outputLL, outputS}: unit =
compile {input = input,
resolve = genFromSsa2,
outputC = outputC,
outputLL = outputLL,
outputS = outputS}
end