Commit e46b90d2 authored by Axel Simon's avatar Axel Simon

have a C struct as state

parent 8840fed7
......@@ -58,7 +58,8 @@ structure C1 = struct
closureToFun : SymbolTable.symid SymMap.map,
recordMapping : Atom.atom AtomMap.map,
allocFuncs : int AtomMap.map ref,
preDeclEmit : Layout.t list ref }
preDeclEmit : Layout.t list ref,
stateType : Imp.vtype ref }
fun isVOIDvtype VOIDvtype = true
| isVOIDvtype _ = false
......@@ -196,7 +197,8 @@ structure C1 = struct
closureToFun = #closureToFun s,
allocFuncs = #allocFuncs s,
recordMapping = #recordMapping s,
preDeclEmit = #preDeclEmit s } : state
preDeclEmit = #preDeclEmit s,
stateType = #stateType s } : state
end
fun registerSymbol (sym,s : state) = regSym (sym, !SymbolTables.varTable, s)
fun registerFSymbol (sym,s : state) = regSym (sym, !SymbolTables.fieldTable, s)
......@@ -213,7 +215,8 @@ structure C1 = struct
closureToFun = #closureToFun s,
allocFuncs = #allocFuncs s,
recordMapping = #recordMapping s,
preDeclEmit = #preDeclEmit s } : state
preDeclEmit = #preDeclEmit s,
stateType = #stateType s } : state
fun par arg = seq [str "(", arg, str ")"]
fun list (lp,arg,xs,rp) = [str lp, seq (separate (map arg xs, ",")), str rp]
......@@ -651,6 +654,17 @@ 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,_,[]))])) =
let
val _ = #stateType s := t
fun setField (f,e) =
seq [
str "s->state", str (if boxed then "->" else "."),
emitFieldSym s f, str " = ", emitExp s e, str ";"]
in
align (map setField fs)
end
| emitExp s (PRIexp (f,t,es)) = (case t of
FUNvtype (_,_,args) => emitPrim s (f,es,args)
| _ => emitPrim s (f,es,[])
......@@ -1003,11 +1017,17 @@ structure C1 = struct
closureToFun = closureToFunMap,
allocFuncs = ref AtomMap.empty,
recordMapping = recordMapping,
preDeclEmit = ref []
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 recordMapping = case !(#stateType s) of
RECORDvtype (_,fs) =>
AtomMap.insert (#recordMapping s, genRecSignature fs,
Atom.atom "monad")
| _ => #recordMapping s
val s = {
names = #names s,
prefix = #prefix s,
......@@ -1019,8 +1039,9 @@ structure C1 = struct
constrs = #constrs s,
closureToFun = #closureToFun s,
allocFuncs = #allocFuncs s,
recordMapping = #recordMapping s,
preDeclEmit = #preDeclEmit s
recordMapping = recordMapping,
preDeclEmit = #preDeclEmit s,
stateType = #stateType s
} : state
val funDeclsPublic = map (emitDecl s)
(List.filter (fn d => SymSet.member(exports, getDeclName d)) ds)
......@@ -1044,9 +1065,7 @@ structure C1 = struct
map (str o Atom.toString o #1)
(ListMergeSort.sort (fn ((_,i1),(_,i2)) => i1>i2)
(AtomMap.listItemsi (!(#allocFuncs s))))
val fields = []
val constructorNames = str ""
val fieldNames = str ""
val state = emitType s (SOME "state", !(#stateType s))
val _ =
C1Templates.expandHeader outputName [
......@@ -1064,8 +1083,7 @@ structure C1 = struct
C1Templates.mkHook ("renamings", align renamings),
C1Templates.mkHook ("records", align (genRecordDecl s true)),
C1Templates.mkHook ("exports", align funDeclsPublic),
C1Templates.mkHook ("tagnames", align constructors),
C1Templates.mkHook ("fields", align fields)
C1Templates.mkHook ("tagnames", align constructors)
]
val _ =
C1Templates.expandRuntime outputName [
......@@ -1084,7 +1102,7 @@ structure C1 = struct
C1Templates.mkHook ("destroy", str (prefix ^ "destroy")),
C1Templates.mkHook ("alloc_funcs", align recAllocFuncs),
C1Templates.mkHook ("records", align (genRecordDecl s false)),
C1Templates.mkHook ("fieldnames", fieldNames),
C1Templates.mkHook ("state_type", indent 2 state),
C1Templates.mkHook ("prototypes", align funDeclsPrivate),
C1Templates.mkHook ("functions", align funs)
]
......
......@@ -5,11 +5,16 @@
#include <string.h>
#include <stdio.h>
/* generated declarations for records with fixed fields */
@records@
struct state {
char* heap_base; /* the beginning of the heap */
char* heap_limit; /* first byte beyond the heap buffer */
char* heap; /* current top of the heap */
obj_t state; /* a heap pointer to the current monadic state */
@state_type@
; /* the current monadic state */
char* ip_base; /* beginning of code buffer */
char* ip_limit; /* first byte beyond the code buffer */
char* ip; /* current pointer into the buffer */
......@@ -65,7 +70,6 @@ void
s->heap_base = heap;
s->heap = heap+sizeof(char*);
s->heap_limit = heap+CHUNK_SIZE;
s->state = 0;
};
size_t
......@@ -91,10 +95,6 @@ static inline void* MALLOC_ATTR alloc(state_t s, size_t bytes) {
return res;
};
/* generated declarations for records with fixed fields */
@records@
#define GEN_ALLOC(type) \
static inline type ## _t* alloc_ ## type (state_t s, type ## _t v) { \
type ## _t* res = alloc(s, sizeof(type ## _t));\
......
......@@ -541,6 +541,7 @@ structure Simplify = struct
fun visitStmt s (ASSIGNstmt (res,exp)) = (case visitExp s exp of
PRIexp (RAISEprim,t,es) => ASSIGNstmt (NONE, PRIexp (RAISEprim,t,es))
| PRIexp (SETSTATEprim,t,es) => ASSIGNstmt (NONE, PRIexp (SETSTATEprim,t,es))
| exp => ASSIGNstmt (res, exp)
)
| visitStmt s (IFstmt (c,t,e)) = IFstmt (visitExp s c, visitBlock s t, visitBlock s e)
......@@ -596,6 +597,7 @@ structure Simplify = struct
PRIexp (SLICEprim,t,[e,LITexp (INTvtype, INTlit (ofs1+ofs2)), LITexp (INTvtype, INTlit size1)])
| e => PRIexp (SLICEprim,t,[e,LITexp (INTvtype, INTlit ofs1), LITexp (INTvtype, INTlit size1)])
)
| visitExp s (PRIexp (SETSTATEprim,_,[PRIexp (GETSTATEprim,_,[])])) = PRIexp (VOIDprim,VOIDvtype,[])
| visitExp s (PRIexp (f,t,es)) = PRIexp (f,t,map (visitExp s) es)
| visitExp s (IDexp sym) = IDexp sym
| visitExp s (CALLexp (e,es)) =
......@@ -619,7 +621,9 @@ structure Simplify = struct
)
| visitExp s (RECORDexp (rs,t,fs)) = RECORDexp (rs,t,map (fn (f,e) => (f,visitExp s e)) fs)
| visitExp s (SELECTexp (rs,t,f,e)) = SELECTexp (rs,t,f,visitExp s e)
| visitExp s (UPDATEexp (rs,t,fs,e)) = UPDATEexp (rs,t,map (fn (f,e) => (f,visitExp s e)) fs,visitExp s e)
| visitExp s (UPDATEexp (rs,t,fs,e)) =
if List.null fs then visitExp s e else
UPDATEexp (rs,t,map (fn (f,e) => (f,visitExp s e)) fs,visitExp s e)
| visitExp s (LITexp l) = LITexp l
| visitExp s (BOXexp (t,e)) = (case visitExp s e of
UNBOXexp (t2,e) => e
......@@ -778,7 +782,8 @@ structure TypeRefinement = struct
typeTable : stype DynamicArray.array,
origDecls : decl SymMap.map,
origLocals : (vtype SymMap.map) ref,
origFields : vtype SymMap.map
origFields : vtype SymMap.map,
stateSym : SymbolTable.symid
}
fun showSType (VOIDstype) = "void"
......@@ -1092,14 +1097,16 @@ structure TypeRefinement = struct
in
lub (s,symType s sym, visitCall s (vtypeToStype s t, es))
end
(*| visitExp s (PRIexp (SETSTATEprim,t, [CALLexp (IDexp sym,es)])) =
(case SymMap.find (#origDecls s, sym) of
SOME (UPDATEdecl {
updateFields = fs,
...
}) => visitCall s (vtypeToStype s t, [CALLexp (IDexp sym,es)])
| _ => visitCall s (vtypeToStype s t, [CALLexp (IDexp sym,es)])
)*)
| visitExp s (PRIexp (SETSTATEprim,_, [UPDATEexp (rs,_,fs,PRIexp (GETSTATEprim,_,[]))])) =
let
val recTy = lub (s, symType s (#stateSym s), symType s rs)
val fields = map (fn (f,e) => (true,f,visitExp s e)) fs
val _ = lub (s, recTy, RECORDstype (freshTVar s, fields, true))
in
VOIDstype
end
| visitExp s (PRIexp (SETSTATEprim,_,[e])) = (lub (s, symType s (#stateSym s), visitExp s e); VOIDstype)
| visitExp s (PRIexp (GETSTATEprim,_,[])) = symType s (#stateSym s)
| visitExp s (PRIexp (f,t,es)) = visitCall s (vtypeToStype s t, es)
| visitExp s (CALLexp (e,es)) = visitCall s (visitExp s e, es)
| visitExp s (INVOKEexp (t,e,es)) = visitCall s (visitExp s e, es)
......@@ -1461,6 +1468,8 @@ structure TypeRefinement = struct
in
readWrap s (argTy, symType s argSym, PRIexp (GET_CON_ARGprim,t,map (patchExp s) es))
end
| patchExp s (PRIexp (GETSTATEprim, t, [])) = PRIexp (GETSTATEprim, adjustType s (t,FUNstype (symType s (#stateSym s), VOIDstype, [])), [])
| patchExp s (PRIexp (SETSTATEprim, t, [e])) = PRIexp (SETSTATEprim, adjustType s (t,FUNstype (VOIDstype, VOIDstype, [symType s (#stateSym s)])), [patchExp s e])
| patchExp s (PRIexp (f,t,es)) = PRIexp (f,t,map (patchExp s) es)
| patchExp s (CALLexp (e,es)) =
let
......@@ -1653,6 +1662,9 @@ structure TypeRefinement = struct
fun run { decls = ds, fdecls = fs, exports = es } =
let
(* register one symbol to track the type of the global state *)
val (tab, stateSym) = SymbolTable.fresh (!SymbolTables.varTable, Atom.atom Primitives.globalState)
val _ = SymbolTables.varTable := tab
val declMap = foldl (fn (decl,m) => SymMap.insert (m,getDeclName decl, decl)) SymMap.empty ds
val state : state = {
......@@ -1661,7 +1673,8 @@ structure TypeRefinement = struct
typeTable = DynamicArray.array (4000, VOIDstype),
origDecls = declMap,
origLocals = ref SymMap.empty,
origFields = fs
origFields = fs,
stateSym = stateSym
}
fun visitDeclPrint state d = ((*debugOn:=(SymbolTable.toInt(getDeclName d)= ~1);*) (*TextIO.print ("type of writeRes : " ^ showSType (inlineSType state (symType state ((SymbolTable.unsafeFromInt 1045)))) ^ " at " ^ SymbolTable.getString(!SymbolTables.varTable, getDeclName d) ^ "\n");*) visitDecl state d)
val _ = map (visitDeclPrint state) ds
......
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