Commit 8840fed7 authored by Axel Simon's avatar Axel Simon

turn record updates into a native operation

parent 113c880f
......@@ -688,6 +688,23 @@ structure C1 = struct
else
seq [emitExp s e, str ".", emitFieldSym s f]
| emitExp s (SELECTexp (rs,t,f,e)) = seq [emitSelect s f, fArgs [str (getFieldTag f), emitExp s e]]
| emitExp s (UPDATEexp (rs,OBJvtype,fs,e)) =
let
val recStripped =
seq [
str "del_fields",
fArgs [
seq (str "(field_tag_t[])" :: list ("{",str o Int.toString o SymbolTable.toInt o #1, fs, "}")),
str (Int.toString (length fs)),
emitExp s e]]
fun recAdd ((f,e),layout) =
align [
seq [emitAddField s f, str "(s,", str (getFieldTag f), str ",", emitExp s e, str ","],
indent 2 (seq [layout, str ")"])]
in
foldl recAdd recStripped fs
end
| emitExp s (UPDATEexp (rs,_,fs,e)) = raise CodeGenBug (* we can't copy a C struct and set a field as a C expression *)
| emitExp s (LITexp (t,VEClit pat)) =
let
fun genNum (c,acc) = IntInf.fromInt 2*acc+(if c= #"1" then 1 else 0)
......
/* vim:ts=2:sw=2:expandtab */
/* vim:set ts=2:set sw=2:set expandtab: */
@I-am-a-template-so-edit-me@
@include-prefix@
......
/* vim:ts=2:sw=2:expandtab */
/* vim:set ts=2:set sw=2:set expandtab: */
@I-am-a-template-so-edit-me@
#ifndef __GDSL_RUNTIME_H
#define __GDSL_RUNTIME_H
......
......@@ -166,28 +166,43 @@ end = struct
case SymbolTable.find (tab, name) of
NONE =>
let
val arg = Atom.atom ("arg_of_" ^ Atom.toString name)
val (tab, sym) = SymbolTable.fresh (tab, name)
val (tab, sym') = SymbolTable.fresh (tab, arg)
val (tab, symArg) = SymbolTable.fresh (tab, Atom.atom "recArg")
val (tab, symRes) = SymbolTable.fresh (tab, Atom.atom "recRes")
val (tab, symDummy) = SymbolTable.fresh (tab, Atom.atom "recSym")
val _ = SymbolTables.varTable := tab
val _ = app (addField s) fields
val argsTy = map (fn _ => OBJvtype) fields
fun genArgs f =
let
val _ = addField s f
val arg = Atom.atom (SymbolTable.getString (ftab,f) ^ "_val")
val tab = !SymbolTables.varTable
val (tab, sym) = SymbolTable.fresh (tab,arg)
val _ = SymbolTables.varTable := tab
in
sym
end
val args = map genArgs fields
val argsTy = map (fn _ => OBJvtype) args
val fType = FUNvtype (OBJvtype, false, argsTy @ [OBJvtype])
val fTypeCl = FUNvtype (OBJvtype, false, [OBJvtype])
val fieldsExps = ListPair.zipEq (fields, map IDexp args)
val body = BASICblock ([],[ASSIGNstmt (SOME symRes,
UPDATEexp (symDummy, OBJvtype, fieldsExps, IDexp symArg))])
val fArgs = map (fn arg => (OBJvtype,arg)) (args @ [symArg])
val _ = addDecl s
(UPDATEdecl { updateName = sym,
updateArg = sym',
updateFields = fields,
updateType = fType })
(FUNCdecl { funcClosure = [],
funcType = fType,
funcName = sym,
funcArgs = fArgs,
funcBody = body,
funcRes = symRes })
val clSym = getClosureSym (s,sym)
val _ = addDecl s (CLOSUREdecl {
closureName = clSym,
closureArgs = argsTy,
closureDelegate = sym,
closureDelArgs = [(OBJvtype,sym')],
closureDelArgs = [(OBJvtype,symArg)],
closureRetTy = OBJvtype
})
in
......
......@@ -24,6 +24,7 @@ structure PatchFunctionCalls = 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 (LITexp l) = LITexp l
| visitExp s (BOXexp (t,e)) = BOXexp (t, visitExp s e)
| visitExp s (UNBOXexp (t,e)) = UNBOXexp (t, visitExp s e)
......@@ -102,6 +103,7 @@ structure ActionClosures = struct
| freeExp s (INVOKEexp (t,e,es)) = foldl (fn (e,s) => freeExp s e) (freeExp s e) es
| freeExp s (RECORDexp (rs,t,fs)) = foldl (fn ((f,e),s) => freeExp s e) s fs
| freeExp s (SELECTexp (rs,t,f,e)) = freeExp s e
| freeExp s (UPDATEexp (rs,t,fs,e)) = foldl (fn ((f,e),s) => freeExp s e) (freeExp s e) fs
| freeExp s (LITexp (t,l)) = s
| freeExp s (BOXexp (t,e)) = freeExp s e
| freeExp s (UNBOXexp (t,e)) = freeExp s e
......@@ -185,6 +187,7 @@ structure ActionClosures = struct
| visitExp s (INVOKEexp (t,e,es)) = INVOKEexp (remMonad t,visitExp s e, map (visitExp s) es)
| 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 (LITexp (t,l)) = LITexp (remMonad t, l)
| visitExp s (BOXexp (t,e)) = BOXexp (remMonad t, visitExp s e)
| visitExp s (UNBOXexp (t,e)) = UNBOXexp (remMonad t, visitExp s e)
......@@ -288,6 +291,7 @@ structure ActionReduce = struct
| getCloFunExp cs (INVOKEexp (t,e,es)) = foldl (fn (e,cs) => getCloFunExp cs e) (getCloFunExp cs e) es
| getCloFunExp cs (RECORDexp (rs,t,fs)) = foldl (fn ((_,e),cs) => getCloFunExp cs e) cs fs
| getCloFunExp cs (SELECTexp (rs,t,f,e)) = getCloFunExp cs e
| getCloFunExp cs (UPDATEexp (rs,t,fs,e)) = foldl (fn ((_,e),cs) => getCloFunExp cs e) (getCloFunExp cs e) fs
| getCloFunExp cs (LITexp l) = cs
| getCloFunExp cs (BOXexp (t,e)) = getCloFunExp cs e
| getCloFunExp cs (UNBOXexp (t,e)) = getCloFunExp cs e
......@@ -405,6 +409,7 @@ structure ActionReduce = struct
| getMonExp (declSyms,execSyms) (CALLexp (e,es)) = foldl (fn (e,execSyms) => getMonExp (declSyms,execSyms) e) (getMonExp (declSyms,execSyms) e) es
| getMonExp (declSyms,execSyms) (INVOKEexp (t,e,es)) = foldl (fn (e,execSyms) => getMonExp (declSyms,execSyms) e) (getMonExp (declSyms,execSyms) e) es
| getMonExp (declSyms,execSyms) (RECORDexp (rs,t,fs)) = foldl (fn ((_,e),execSyms) => getMonExp (declSyms,execSyms) e) execSyms fs
| getMonExp (declSyms,execSyms) (UPDATEexp (rs,t,fs,e)) = foldl (fn ((_,e),execSyms) => getMonExp (declSyms,execSyms) e) (getMonExp (declSyms,execSyms) e) fs
| getMonExp ds (SELECTexp (rs,t,f,e)) = getMonExp ds e
| getMonExp (declSyms,execSyms) (LITexp l) = execSyms
| getMonExp ds (BOXexp (t,e)) = getMonExp ds e
......@@ -614,6 +619,7 @@ 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 (LITexp l) = LITexp l
| visitExp s (BOXexp (t,e)) = (case visitExp s e of
UNBOXexp (t2,e) => e
......@@ -659,14 +665,34 @@ structure Simplify = struct
funcRes = res,
...
}),[e]) =
if not (SymbolTable.eq_symid (arg,symArg)) orelse
not (SymbolTable.eq_symid (res,symRes)) then NONE else
let
val tab = !SymbolTables.varTable
val (tab, symDum) = SymbolTable.fresh (tab, Atom.atom "dummy_select")
val _ = SymbolTables.varTable := tab
in
if SymbolTable.eq_symid (arg,symArg) andalso
SymbolTable.eq_symid (res,symRes) then
SOME (SELECTexp (symDum,t, field, e)) else NONE
SOME (SELECTexp (symDum, t, field, e))
end
| getTrivialFunctionBody (SOME (FUNCdecl {
funcArgs = args,
funcBody = BASICblock ([], [
ASSIGNstmt (SOME symRes, UPDATEexp (rs,t,fs,recArg))
]),
funcRes = res,
...
}),es) =
if not (List.all (fn ((_,arg),exp) => case exp of
IDexp sym => SymbolTable.eq_symid (arg,sym)
| _ => false) (ListPair.zip (args,map #2 fs @ [recArg]))) orelse
not (List.length es=List.length args) orelse
not (SymbolTable.eq_symid (res,symRes)) then NONE else
let
val tab = !SymbolTables.varTable
val (tab, symDum) = SymbolTable.fresh (tab, Atom.atom "dummy_select")
val _ = SymbolTables.varTable := tab
in
SOME (UPDATEexp (symDum, t, ListPair.zip (map #1 fs, es), List.last es))
end
| getTrivialFunctionBody _ = NONE
......@@ -1066,6 +1092,14 @@ 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 (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)
......@@ -1091,6 +1125,13 @@ structure TypeRefinement = struct
else
(lub (s, symType s rs, lub (s,OBJstype,visitExp s e));
fieldType s f)
| visitExp s (UPDATEexp (rs,t,fs,e)) =
let
val sFields = map (fn (f,e) => (true,f,lub (s,fieldType s f, visitExp s e))) fs
val _ = lub (s, symType s rs, RECORDstype (freshTVar s,sFields,true))
in
lub (s, lub (s,OBJstype, symType s rs), visitExp s e)
end
| visitExp s (LITexp (ty,lit)) = vtypeToStype s ty
| visitExp s (BOXexp (t,e)) = BOXstype (visitExp s e)
| visitExp s (UNBOXexp (t,e)) =
......@@ -1463,6 +1504,18 @@ structure TypeRefinement = struct
in
readWrap s (origTy, newTy, SELECTexp (rs,adjustType s (t, sTy), f, patchExp s e))
end
| patchExp s (UPDATEexp (rs,t,fs,e)) =
let
val sTy = inlineSType s (symType s rs)
fun genWrap (f,e) =
let
val (origTy,newTy) = genFieldTypes (s,t,sTy,f)
in
(f, writeWrap s (origTy, newTy, patchExp s e))
end
in
UPDATEexp (rs, adjustType s (t, sTy), map genWrap fs, patchExp s e)
end
| patchExp s (LITexp l) = LITexp l
| patchExp s (BOXexp (t,e)) = BOXexp (t, patchExp s e)
| patchExp s (UNBOXexp (t,e)) = UNBOXexp (t, patchExp s e)
......@@ -1958,6 +2011,7 @@ structure SwitchReduce = struct
| visitExp s (INVOKEexp (t,e,es)) = (INVOKEexp (t,visitExp s e, map (visitExp s) es))
| 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 (BOXexp (t,e)) = BOXexp (t, visitExp s e)
| visitExp s (UNBOXexp (t,e)) = UNBOXexp (t, visitExp s e)
| visitExp s (VEC2INTexp (sz,e)) = VEC2INTexp (sz, visitExp s e)
......@@ -2064,6 +2118,7 @@ structure DeadFunctions = struct
| visitExp s (INVOKEexp (t,e,es)) = INVOKEexp (t,visitExp s e, map (visitExp s) es)
| 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 (BOXexp (t,e)) = BOXexp (t, visitExp s e)
| visitExp s (UNBOXexp (t,e)) = UNBOXexp (t, visitExp s e)
| visitExp s (VEC2INTexp (sz,e)) = VEC2INTexp (sz, visitExp s e)
......@@ -2220,6 +2275,15 @@ structure DeadVariables = struct
(s, RECORDexp (rs,t,fs))
end
| visitExp s (SELECTexp (rs,t,f,e)) = let val (s,e) = visitExp s e in (s,SELECTexp (rs,t,f,e)) end
| visitExp s (UPDATEexp (rs,t,fs,e)) =
let
val (s,e) = visitExp s e
fun visitField s (f,e) =
let val (s,e) = visitExp s e in (s,(f,e)) end
val (s,fs) = visit visitField s fs
in
(s, UPDATEexp (rs,t,fs,e))
end
| visitExp s (BOXexp (t,e)) = let val (s,e) = visitExp s e in (s,BOXexp (t,e)) end
| visitExp s (UNBOXexp (t,e)) = let val (s,e) = visitExp s e in (s,UNBOXexp (t,e)) end
| visitExp s (VEC2INTexp (sz,e)) = let val (s,e) = visitExp s e in (s,VEC2INTexp (sz,e)) end
......
......@@ -149,6 +149,7 @@ structure Imp = struct
| INVOKEexp of vtype * exp * exp list (* callee is a closure, type is that of exp *)
| RECORDexp of rec_sym * vtype * (sym * exp) list
| SELECTexp of rec_sym * vtype * sym * exp (* type is that of the record exp *)
| UPDATEexp of rec_sym * vtype * (sym * exp) list * exp (* type is that of the record exp *)
| LITexp of vtype * lit
| BOXexp of vtype * exp
| UNBOXexp of vtype * exp
......@@ -259,6 +260,8 @@ structure Imp = struct
| exp (INVOKEexp (t,f,es)) = seq (vtype t :: space :: str "*" :: exp f :: args ("(",exp,es,")"))
| exp (RECORDexp (_,t,fs)) = seq (vtype t :: space :: args ("{",field,fs,"}"))
| exp (SELECTexp (_,t,f,e)) = seq [str "(", vtype t, str ")", exp e, space, str ".", fld f]
| exp (UPDATEexp (_,t,fs,e)) =
seq ([vtype t] @ args ("[",field,fs,"]") @ [str "(", exp e, str ")"])
| exp (LITexp l) = lit l
| exp (BOXexp (t,e)) = seq [str "box[", vtype t, str "](", exp e, str ")"]
| exp (UNBOXexp (t,e)) = seq [str "unbox[", vtype t, str "](", exp e, str ")"]
......
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