Commit 30cc8d9e authored by Julian Kranz's avatar Julian Kranz

---

parents fb5d0472 9230a5a2
......@@ -66,18 +66,16 @@ structure PrettyC = struct
end
structure C0Templates = struct
val header = ExpandFile.mkTemplateFromFile "detail/codegen/c0/runtime.h"
val runtime = ExpandFile.mkTemplateFromFile "detail/codegen/c0/runtime.c"
fun expandHeader hooks =
fun expandHeader path hooks =
ExpandFile.expandTemplate
{src=header,
{src=ExpandFile.mkTemplateFromFile (path ^ "/c0/runtime.h"),
dst="dis.h",
hooks=hooks}
fun expandRuntime hooks =
fun expandRuntime path hooks =
ExpandFile.expandTemplate
{src=runtime,
{src=ExpandFile.mkTemplateFromFile (path ^ "/c0/runtime.c"),
dst="dis.c",
hooks=hooks}
......@@ -418,13 +416,14 @@ structure C = struct
end
val funs = map emitFun clos
val path = Controls.get BasicControl.runtimePath
val _ =
C0.expandHeader
C0.expandHeader path
[C0.mkConstrutorsHook (align constructors),
C0.mkFieldsHook (align fields),
C0.mkExportsHook (align externPrototypes)]
val _ =
C0.expandRuntime
C0.expandRuntime path
[C0.mkPrototypesHook (align staticPrototypes),
C0.mkFunctionsHook (align funs),
C0.mkTagNamesHook constructorNames,
......
......@@ -21,13 +21,13 @@ structure C1Templates = struct
fun expandHeader path basename hooks =
ExpandFile.expandTemplate
{src=ExpandFile.mkTemplateFromFile (path ^ "/runtime.h"),
{src=ExpandFile.mkTemplateFromFile (path ^ "/c1/runtime.h"),
dst=basename ^ ".h",
hooks=stdHooks basename @ hooks}
fun expandRuntime path basename hooks =
ExpandFile.expandTemplate
{src=ExpandFile.mkTemplateFromFile (path ^ "/runtime.c"),
{src=ExpandFile.mkTemplateFromFile (path ^ "/c1/runtime.c"),
dst=basename ^ ".c",
hooks=stdHooks basename @ hooks}
......@@ -134,7 +134,8 @@ structure C1 = struct
"mktemp",
"logb",
"div",
"memcpy"
"memcpy",
"s"
])
fun mangleName s =
......@@ -268,6 +269,8 @@ structure C1 = struct
fun genRecSignature fs =
let
fun fieldCmp ((f1,_),(f2,_)) = SymbolTable.compare_symid (f1,f2)
val fs = ListMergeSort.uniqueSort fieldCmp fs
val str = foldl (fn ((f,t),str) =>
Atom.toString (SymbolTable.getAtom (!SymbolTables.fieldTable, f)) ^ str) "" fs
in
......@@ -825,46 +828,6 @@ structure C1 = struct
])
end
end
| emitDecl s (UPDATEdecl {
updateName = name,
updateArg = arg,
updateFields = fs,
updateType = ty
}) =
let
val recVar = #ret (s : state)
val s = registerSymbol (recVar,s)
val s = foldl registerFSymbol s fs
fun fieldName f = Atom.toString (SymbolTable.getAtom (!SymbolTables.fieldTable,f))
val args = map (fn f => (SymMap.lookup (#fieldTypes s,f), f)) fs @ [(OBJvtype, recVar)]
in
if #onlyDecls s then
let
val fTy = emitFunType s (name, args, ty)
val preDecl = !(#preDeclEmit s)
val _ = (#preDeclEmit s) := []
in
align (
preDecl @ [
seq [str "static", space, fTy, str ";"]
])
end
else
align [
seq [str "static", space, emitFunType s (name, args, ty), space, str "{"],
indent 2 (align ([
seq (str "field_tag_t tags[] = " :: list ("{",str o getFieldTag, fs, "};")),
seq [emitSym s recVar, str " = del_fields(s,tags,sizeof(tags)/sizeof(tags[0]),", emitSym s recVar, str ");"]
] @ map (fn f =>
seq [emitSym s recVar, str " = ",
emitAddField s f, str "(s,", str (getFieldTag f), str ", ",
emitSym s f, str ", ", emitSym s recVar, str ");"]) fs
@ [
seq [str "return ", emitSym s recVar, str ";"]
])),
str "}"
]
end
| emitDecl s (CONdecl {
conName = name,
conTag = tag,
......@@ -954,10 +917,9 @@ structure C1 = struct
fun genRecordMapping ((tySym, ty), m) =
let
fun fieldCmp ((f1,_),(f2,_)) = SymbolTable.compare_symid (f1,f2)
fun addRec (SpecAbstractTree.MARKty t) = addRec (#tree t)
| addRec (SpecAbstractTree.RECORDty fs) =
AtomMap.insert (m, genRecSignature (ListMergeSort.uniqueSort fieldCmp fs),
AtomMap.insert (m, genRecSignature fs,
SymbolTable.getAtom (!SymbolTables.typeTable,tySym))
| addRec _ = m
in
......@@ -971,9 +933,12 @@ structure C1 = struct
val _ = genClosureSet := AtomSet.empty
val _ = invokeClosureSet := AtomSet.empty
val { decls = ds, fdecls = fs, exports } = Spec.get #declarations spec
val { decls = ds, fdecls = fs, exports, monad = mt } = Spec.get #declarations spec
val recordMapping = foldl genRecordMapping AtomMap.empty (Spec.get #typealias spec)
val recordMapping = case mt of
RECORDvtype (_,fs) => AtomMap.singleton (genRecSignature fs, Atom.atom "monad")
| _ => AtomMap.empty
val recordMapping = foldl genRecordMapping recordMapping (Spec.get #typealias spec)
val closureToFunMap = foldl (fn (d,m) => case d of
CLOSUREdecl {
......@@ -1000,7 +965,6 @@ structure C1 = struct
val st = !SymbolTables.varTable
val (st, genericSym) = SymbolTable.fresh (st,Atom.atom "v")
val (st, stateSym) = SymbolTable.fresh (st,Atom.atom "s")
val _ = SymbolTables.varTable := st
val exports = SymSet.fromList (Spec.get #exports spec)
val s = {
......@@ -1018,7 +982,6 @@ structure C1 = struct
preDeclEmit = ref [],
stateType = ref OBJvtype
} : state
val s = registerSymbol (stateSym, s)
val s = foldl registerSymbol s (map getDeclName ds)
val funs = map (emitDecl s) ds
val s = {
......
structure JS0Templates = struct
val runtime = ExpandFile.mkTemplateFromFile "detail/codegen/js0/runtime.js"
fun expandRuntime hooks =
fun expandRuntime path hooks =
ExpandFile.expandTemplate
{src=runtime,
{src=ExpandFile.mkTemplateFromFile (path ^ "/js0/runtime.js"),
dst="dis.js",
hooks=hooks}
......@@ -156,8 +155,9 @@ structure JS0 = struct
in
Program.T (Vector.fromList jsfuns)
end
val path = Controls.get BasicControl.runtimePath
val _ =
JS0Templates.expandRuntime
JS0Templates.expandRuntime path
[JS0Templates.mkFunctionsHook (Program.layout js)]
in
js
......
......@@ -154,7 +154,7 @@ structure BasicControl : sig
pri = [0],
obscurity = 0,
help = "path to the runtime files",
default = "./detail/codegen/c1/"
default = "./detail/codegen/"
}
(* the prefix for exported functions*)
......
......@@ -604,7 +604,8 @@ end = struct
in
{ decls = !decls,
fdecls = !fields,
exports = Spec.get #exports spec }
exports = Spec.get #exports spec,
monad = OBJvtype }
end) spec
fun dumpPre (os, spec) = Pretty.prettyTo (os, Core.PP.spec spec)
......
......@@ -58,11 +58,11 @@ structure PatchFunctionCalls = struct
}
| visitDecl s d = d
fun run ({ decls = ds, fdecls = fs, exports = es } : imp) =
fun run ({ decls = ds, fdecls = fs, exports = es, monad = mt } : imp) =
let
val ds = map (visitDecl {}) ds
in
{ decls = ds, fdecls = fs, exports = es } : imp
{ decls = ds, fdecls = fs, exports = es, monad = mt } : imp
end
end
......@@ -243,12 +243,12 @@ structure ActionClosures = struct
},s) = SymMap.insert (s, del, name)
| genFunToClosure (d,s) = s
fun run { decls = ds, fdecls = fs, exports = es } =
fun run { decls = ds, fdecls = fs, exports = es, monad = mt } =
let
val s = foldl genFunToClosure SymMap.empty ds
val ds = visitDecl s ds
in
{ decls = ds, fdecls = fs, exports = es }
{ decls = ds, fdecls = fs, exports = es, monad = mt }
end
end
......@@ -498,7 +498,7 @@ structure ActionReduce = struct
| visitDecl s d = d
fun run { decls = ds, fdecls = fs, exports = es } =
fun run { decls = ds, fdecls = fs, exports = es, monad = mt } =
let
fun fixpoint (size,set) =
let
......@@ -521,7 +521,7 @@ structure ActionReduce = struct
val sVar = { monVars = pureToMon } : stateVar
val ds = map (visitDecl sVar) ds
in
{ decls = ds, fdecls = fs, exports = es }
{ decls = ds, fdecls = fs, exports = es, monad = mt }
end
end
......@@ -718,7 +718,7 @@ structure Simplify = struct
}
| visitDecl s d = d
fun run ({ decls = ds, fdecls = fs, exports = es } : imp) =
fun run ({ decls = ds, fdecls = fs, exports = es, monad = mt } : imp) =
let
val declMap = foldl (fn (decl,m) => SymMap.insert (m,getDeclName decl, decl)) SymMap.empty ds
val state = { decls = declMap,
......@@ -726,7 +726,7 @@ structure Simplify = struct
stmtsRef = ref ([] : stmt list) } : state
val ds = map (visitDecl state) ds
in
{ decls = ds, fdecls = fs, exports = es } : imp
{ decls = ds, fdecls = fs, exports = es, monad = mt } : imp
end
end
......@@ -1215,18 +1215,6 @@ structure TypeRefinement = struct
in
lub (s, symType s name, ty)
end
| visitDecl s (UPDATEdecl {
updateName = name,
updateArg = arg,
updateFields = fs,
updateType = _
}) =
let
val fsTys = map (fieldType s) fs
val reTy = lub (s, OBJstype, symType s arg)
in
lub (s, symType s name, FUNstype (reTy, OBJstype, fsTys @ [reTy]))
end
| visitDecl s (CONdecl {
conName = name,
conTag = _,
......@@ -1266,7 +1254,6 @@ structure TypeRefinement = struct
SOME t => t
| NONE => (case SymMap.find (#origDecls s, sym) of
(SOME (FUNCdecl { funcType = ty, ... })) => ty
| (SOME (UPDATEdecl { updateType = ty, ... })) => ty
| (SOME (CONdecl { conType = ty, ... })) => ty
| (SOME (CLOSUREdecl { closureArgs = ts, ... })) => FUNvtype (OBJvtype,true,ts)
| NONE => (TextIO.print ("origType: no type of " ^ SymbolTable.getString(!SymbolTables.varTable, sym) ^ "\n"); raise TypeOptBug)
......@@ -1275,11 +1262,6 @@ structure TypeRefinement = struct
fun getArgTypes s sym = case SymMap.find (#origDecls s, sym) of
SOME (FUNCdecl { funcArgs = args, ... }) =>
map (fn (t,sym) => (t,symType s sym)) args
| SOME (UPDATEdecl { updateName = sym, updateType = t, ... }) =>
(case (t,inlineSType s (symType s sym)) of
(FUNvtype (_,_,vArgs), FUNstype (_,_,sArgs)) => ListPair.zip (vArgs,sArgs)
| (v,s) => (TextIO.print ("getArgTypes: update function " ^ SymbolTable.getString(!SymbolTables.varTable, sym) ^ " has unequal no of args: " ^ Layout.tostring (Imp.PP.vtype v) ^ " and " ^ showSType s ^ "\n"); raise TypeOptBug)
)
| SOME (CONdecl { conName = name, conArg = (_,arg), ... }) =>
[(origType s arg, symType s arg)]
| SOME (CLOSUREdecl { closureName = name, closureArgs = ts, ... }) =>
......@@ -1381,17 +1363,6 @@ structure TypeRefinement = struct
funcRes = res
}
end
| patchDecl s (UPDATEdecl {
updateName = name,
updateArg = arg,
updateFields = fs,
updateType = vtype
}) = UPDATEdecl {
updateName = name,
updateArg = arg,
updateFields = fs,
updateType = adjustType s (vtype, symType s name)
}
| patchDecl s (CONdecl {
conName = name,
conTag = tag,
......@@ -1632,11 +1603,6 @@ structure TypeRefinement = struct
in
()
end
| setArgsToTop (es,s) (UPDATEdecl {
updateArg = sym,
...
}) =
ignore (lub (s, symType s sym, voidsToTop false (inlineSType s (symType s sym))))
| setArgsToTop (es,s) (CONdecl {
conArg = (_,sym),
...
......@@ -1661,7 +1627,7 @@ structure TypeRefinement = struct
DynamicArray.foldl checkForRecord AtomMap.empty (#typeTable s)
end
fun run { decls = ds, fdecls = fs, exports = es } =
fun run { decls = ds, fdecls = fs, exports = es, monad = mt } =
let
(* register one symbol to track the type of the global state *)
val (tab, stateSym) = SymbolTable.fresh (!SymbolTables.varTable, Atom.atom Primitives.globalState)
......@@ -1689,8 +1655,9 @@ structure TypeRefinement = struct
fun patchDeclPrint state d = (debugOn:=(SymbolTable.toInt(getDeclName d)= ~1); msg ("patching " ^ SymbolTable.getString(!SymbolTables.varTable, getDeclName d) ^ "\n"); patchDecl state d)*)
val ds = map (patchDecl state) ds
val fs = SymMap.mapi (fn (sym,ty) => adjustType state (ty, fieldType state sym)) fs
val mt = adjustType state (mt, symType state stateSym)
in
{ decls = ds, fdecls = fs, exports = es }
{ decls = ds, fdecls = fs, exports = es, monad = mt }
end
end
......@@ -2052,11 +2019,11 @@ structure SwitchReduce = struct
}
| visitDecl s d = d
fun run { decls = ds, fdecls = fs, exports = es } =
fun run { decls = ds, fdecls = fs, exports = es, monad = mt } =
let
val ds = map (visitDecl {}) ds
in
{ decls = ds, fdecls = fs, exports = es }
{ decls = ds, fdecls = fs, exports = es, monad = mt }
end
end
......@@ -2168,7 +2135,7 @@ structure DeadFunctions = struct
}) = if SymSet.member(!(#referenced s), name) then refSym (s : state) del else ()
| visitCDecl s _ = ()
fun run { decls = ds, fdecls = fs, exports = es } =
fun run { decls = ds, fdecls = fs, exports = es, monad = mt } =
let
val s = { locals = SymSet.empty,
replace = ref SymMap.empty,
......@@ -2186,7 +2153,7 @@ structure DeadFunctions = struct
end
val ds = fixpoint ()
in
{ decls = ds, fdecls = fs, exports = es }
{ decls = ds, fdecls = fs, exports = es, monad = mt }
end
end
......@@ -2349,21 +2316,17 @@ structure DeadVariables = struct
})
| visitDecl d = d
fun addPure (UPDATEdecl {
updateName = sym,
...
}) = (pureSet := SymSet.add(!pureSet,sym))
| addPure (CONdecl {
fun addPure (CONdecl {
conName = sym,
...
}) = (pureSet := SymSet.add(!pureSet,sym))
| addPure _ = ()
fun run { decls = ds, fdecls = fs, exports = es } =
fun run { decls = ds, fdecls = fs, exports = es, monad = mt } =
let
val _ = app addPure ds
in
{ decls = map visitDecl ds, fdecls = fs, exports = es }
{ decls = map visitDecl ds, fdecls = fs, exports = es, monad = mt }
end
end
......@@ -122,12 +122,6 @@ structure Imp = struct
funcBody : block,
funcRes : sym
}
| UPDATEdecl of {
updateName : sym,
updateArg : sym,
updateFields : sym list, (* field symbols *)
updateType : vtype
}
| CONdecl of {
conName : sym,
conTag : sym, (* constructor symbol *)
......@@ -179,7 +173,6 @@ structure Imp = struct
| CONlit of sym
fun getDeclName (FUNCdecl { funcName = name, ... }) = name
| getDeclName (UPDATEdecl { updateName = name, ... }) = name
| getDeclName (CONdecl { conName = name, ... }) = name
| getDeclName (CLOSUREdecl { closureName = name, ... }) = name
......@@ -188,7 +181,8 @@ structure Imp = struct
type imp = {
decls : decl list,
fdecls : vtype SymMap.map,
exports : sym list
exports : sym list,
monad : vtype
}
structure Spec = struct
......@@ -234,8 +228,6 @@ structure Imp = struct
),
block funcBody
]
| decl (UPDATEdecl { updateName = name, updateArg = arg, updateFields = fs, updateType = t }) =
seq ([vtype t, space, var name, str ";"] @ args ("[",fld, fs, "]") @ [str "(", var arg, str ")"])
| decl (CONdecl { conName = name, conTag = tag, conArg = conArg, conType = t }) =
seq [vtype t, space, var name, str "(", arg conArg, str ");"]
| decl (CLOSUREdecl { closureName = name, closureArgs = ts,
......@@ -306,7 +298,7 @@ structure Imp = struct
and def (intro, body) =
align [seq [intro, space, str "="], indent 3 body]
fun decls ds = align (map decl ds)
fun imp ({ decls = ds, fdecls = fs, exports } : imp) = decls ds
fun imp ({ decls = ds, fdecls = fs, exports, monad } : imp) = decls ds
val pretty = Pretty.pretty o imp
val spec = Spec.PP.spec imp
end
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment