Commit 738ebf56 authored by Axel Simon's avatar Axel Simon

ensure that only one state declaration is emitted

parent 143c12db
......@@ -59,7 +59,7 @@ structure C1 = struct
recordMapping : Atom.atom AtomMap.map,
allocFuncs : int AtomMap.map ref,
preDeclEmit : Layout.t list ref,
stateType : Imp.vtype ref }
stateType : Imp.vtype }
fun isVOIDvtype VOIDvtype = true
| isVOIDvtype _ = false
......@@ -136,7 +136,8 @@ structure C1 = struct
"mktemp",
"logb",
"div",
"memcpy"
"memcpy",
"s"
])
fun mangleName s =
......@@ -270,6 +271,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
......@@ -655,9 +658,8 @@ structure C1 = struct
and emitExp s (IDexp sym) = emitSym s sym
| emitExp s (PRIexp (SETSTATEprim,_,
[UPDATEexp (rs,t as RECORDvtype (boxed,fsTys),fs,PRIexp (GETSTATEprim,_,[]))])) =
[UPDATEexp (rs,RECORDvtype (boxed,fsTys),fs,PRIexp (GETSTATEprim,_,[]))])) =
let
val _ = #stateType s := t
fun setField (f,e) =
seq [
str "s->state", str (if boxed then "->" else "."),
......@@ -956,10 +958,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
......@@ -973,9 +974,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 {
......@@ -1002,7 +1006,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,9 +1021,8 @@ structure C1 = struct
allocFuncs = ref AtomMap.empty,
recordMapping = recordMapping,
preDeclEmit = ref [],
stateType = ref OBJvtype
stateType = mt
} : state
val s = registerSymbol (stateSym, s)
val s = foldl registerSymbol s (map getDeclName ds)
val funs = map (emitDecl s) ds
val s = {
......@@ -1060,7 +1062,7 @@ structure C1 = struct
map (str o Atom.toString o #1)
(ListMergeSort.sort (fn ((_,i1),(_,i2)) => i1>i2)
(AtomMap.listItemsi (!(#allocFuncs s))))
val state = emitType s (SOME "state", !(#stateType s))
val state = emitType s (SOME "state", (#stateType s))
val _ =
C1Templates.expandHeader outputName [
......
......@@ -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
......@@ -1661,7 +1661,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 +1689,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 +2053,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 +2169,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 +2187,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
......@@ -2359,11 +2360,11 @@ structure DeadVariables = struct
}) = (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
......@@ -188,7 +188,8 @@ structure Imp = struct
type imp = {
decls : decl list,
fdecls : vtype SymMap.map,
exports : sym list
exports : sym list,
monad : vtype
}
structure Spec = struct
......@@ -306,7 +307,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