Commit 82118c7e authored by mb0's avatar mb0
Browse files

Up.

parent 3a080889
......@@ -29,9 +29,9 @@ __obj __FALSE = __WRAP(&__unwrapped_FALSE);
void __fatal (char *fmt, ...) {
va_list ap;
va_start(ap,fmt);
fprintf(stderr,"ERROR:");
fprintf(stderr,"FATAL:[");
vfprintf(stderr,fmt,ap);
fprintf(stderr,"\n");
fprintf(stderr,"]\n");
va_end(ap);
abort();
}
......@@ -120,11 +120,38 @@ __obj __not (__obj a_) {
__obj __raise (__obj o) {
printf("raising: ");
__println(o);
__fatal("<error>");
__fatal("Unhandled exception");
return (o);
}
__obj __unconsume (__obj s) {
__obj __consume8 (__obj s) {
__LOCAL(blob, __RECORD_SELECT(s,___blob));
__char* buf = blob->blob.blob;
__word sz = blob->blob.sz;
if (sz == 0)
__fatal("end-of-blob");
__char x = *buf;
__LOCAL0(v);
__BV_BEGIN(v,8);
__BV_INIT(x);
__BV_END(v,8);
__LOCAL0(blobb);
__BLOB_BEGIN(blobb);
__BLOB_INIT(buf+1,sz-1);
__BLOB_END(blobb);
__LOCAL0(ss);
__RECORD_BEGIN_UPDATE(ss,s);
__RECORD_UPDATE(___blob,blobb);
__RECORD_END_UPDATE(ss);
__LOCAL0(a);
__RECORD_BEGIN(a,2);
__RECORD_ADD(___1,v);
__RECORD_ADD(___2,ss);
__RECORD_END(a,2);
return (a);
}
__obj __unconsume8 (__obj s) {
__LOCAL(blob, __RECORD_SELECT(s,___blob));
__char* buf = blob->blob.blob;
__word sz = blob->blob.sz;
......@@ -144,20 +171,71 @@ __obj __unconsume (__obj s) {
return (a);
}
__obj __consume (__obj s) {
__obj __consume16 (__obj s) {
__LOCAL(blob, __RECORD_SELECT(s,___blob));
__char* buf = blob->blob.blob;
__word sz = blob->blob.sz;
if (sz == 0)
__fatal("<end-of-blob>");
__char x = *buf;
if (sz < 2)
__fatal("end-of-blob");
uint16_t x1 = buf[0];
uint16_t x2 = buf[1]<<8;
__LOCAL0(v);
__BV_BEGIN(v,8);
__BV_INIT(x);
__BV_END(v,8);
__BV_BEGIN(v,16);
__BV_INIT((x1|x2)&0xffff);
__BV_END(v,16);
__LOCAL0(blobb);
__BLOB_BEGIN(blobb);
__BLOB_INIT(buf+1,sz-1);
__BLOB_INIT(buf+2,sz-2);
__BLOB_END(blobb);
__LOCAL0(ss);
__RECORD_BEGIN_UPDATE(ss,s);
__RECORD_UPDATE(___blob,blobb);
__RECORD_END_UPDATE(ss);
__LOCAL0(a);
__RECORD_BEGIN(a,2);
__RECORD_ADD(___1,v);
__RECORD_ADD(___2,ss);
__RECORD_END(a,2);
return (a);
}
__obj __unconsume16 (__obj s) {
__LOCAL(blob, __RECORD_SELECT(s,___blob));
__char* buf = blob->blob.blob;
__word sz = blob->blob.sz;
__LOCAL0(blobb);
__BLOB_BEGIN(blobb);
__BLOB_INIT(buf-2,sz+2);
__BLOB_END(blobb);
__LOCAL0(ss);
__RECORD_BEGIN_UPDATE(ss,s);
__RECORD_UPDATE(___blob,blobb);
__RECORD_END_UPDATE(ss);
__LOCAL0(a);
__RECORD_BEGIN(a,2);
__RECORD_ADD(___1,__UNIT);
__RECORD_ADD(___2,ss);
__RECORD_END(a,2);
return (a);
}
__obj __consume32 (__obj s) {
__LOCAL(blob, __RECORD_SELECT(s,___blob));
__char* buf = blob->blob.blob;
__word sz = blob->blob.sz;
if (sz < 4)
__fatal("end-of-blob");
uint32_t x1 = buf[0];
uint32_t x2 = buf[1]<<8;
uint32_t x3 = buf[2]<<16;
uint32_t x4 = buf[3]<<24;
__LOCAL0(v);
__BV_BEGIN(v,32);
__BV_INIT((x1|x2|x3|x4)&0xffffffff);
__BV_END(v,32);
__LOCAL0(blobb);
__BLOB_BEGIN(blobb);
__BLOB_INIT(buf+2,sz-2);
__BLOB_END(blobb);
__LOCAL0(ss);
__RECORD_BEGIN_UPDATE(ss,s);
......@@ -171,6 +249,26 @@ __obj __consume (__obj s) {
return (a);
}
__obj __unconsume32 (__obj s) {
__LOCAL(blob, __RECORD_SELECT(s,___blob));
__char* buf = blob->blob.blob;
__word sz = blob->blob.sz;
__LOCAL0(blobb);
__BLOB_BEGIN(blobb);
__BLOB_INIT(buf-4,sz+4);
__BLOB_END(blobb);
__LOCAL0(ss);
__RECORD_BEGIN_UPDATE(ss,s);
__RECORD_UPDATE(___blob,blobb);
__RECORD_END_UPDATE(ss);
__LOCAL0(a);
__RECORD_BEGIN(a,2);
__RECORD_ADD(___1,__UNIT);
__RECORD_ADD(___2,ss);
__RECORD_END(a,2);
return (a);
}
__obj __slice (__obj tok_, __obj offs_, __obj sz_) {
__word tok = tok_->bv.vec;
__int offs = offs_->z.value;
......
......@@ -368,9 +368,13 @@ static inline void __resetHeap() {
hp = &heap[__RT_HEAP_SIZE];
}
__obj __consume (__obj);
__obj __consume8(__obj);
__obj __unconsume8(__obj);
__obj __consume16(__obj);
__obj __unconsume16(__obj);
__obj __consume32(__obj);
__obj __unconsume32(__obj);
__obj __slice(__obj,__obj,__obj);
__obj __unconsume(__obj);
__obj __concat(__obj,__obj);
__obj __equal(__obj,__obj);
__obj __and(__obj,__obj);
......
......@@ -298,7 +298,7 @@ structure FreeVars = struct
in
set k env
end) ds
val _ = merge'()
(* XXX: val _ = merge'() *)
val _ = merge'()
val env = visitTerm (env, body)
val env =
......
......@@ -35,8 +35,12 @@ end = struct
fun mk () = let
open Core.Exp
val slice = get "slice"
val consume = get "consume"
val unconsume = get "unconsume"
val consume8 = get "consume8"
val unconsume8 = get "unconsume8"
val consume16 = get "consume16"
val unconsume16 = get "unconsume16"
val consume32 = get "consume32"
val unconsume32 = get "unconsume32"
val andd = get "and"
val concat = get "^"
val == = get "=="
......@@ -157,29 +161,73 @@ end = struct
(slice, [tok, offs, sz], body)
end
(* val consume s = %consume(s) *)
val consume =
(* val consume8 s = %consume8(s) *)
val consume8 =
let
val s = fresh "s"
val primConsume = get "%consume"
val body = PRI (primConsume, [s])
val primconsume8 = get "%consume8"
val body = PRI (primconsume8, [s])
in
(consume, [s], body)
(consume8, [s], body)
end
(* val unconsume s = %unconsume(s) *)
val unconsume =
(* val unconsume8 s = %unconsume8(s) *)
val unconsume8 =
let
val s = fresh "s"
val primUnconsume = get "%unconsume"
val body = PRI (primUnconsume, [s])
val primUnconsume8 = get "%unconsume8"
val body = PRI (primUnconsume8, [s])
in
(unconsume, [s], body)
(unconsume8, [s], body)
end
(* val consume16 s = %consume16(s) *)
val consume16 =
let
val s = fresh "s"
val primconsume16 = get "%consume16"
val body = PRI (primconsume16, [s])
in
(consume16, [s], body)
end
(* val unconsume16 s = %unconsume16(s) *)
val unconsume16 =
let
val s = fresh "s"
val primUnconsume16 = get "%unconsume16"
val body = PRI (primUnconsume16, [s])
in
(unconsume16, [s], body)
end
(* val consume32 s = %consume32(s) *)
val consume32 =
let
val s = fresh "s"
val primconsume32 = get "%consume32"
val body = PRI (primconsume32, [s])
in
(consume32, [s], body)
end
(* val unconsume32 s = %unconsume32(s) *)
val unconsume32 =
let
val s = fresh "s"
val primUnconsume32 = get "%unconsume32"
val body = PRI (primUnconsume32, [s])
in
(unconsume32, [s], body)
end
in
[slice,
consume,
unconsume,
consume8,
unconsume8,
consume16,
unconsume16,
consume32,
unconsume32,
andd,
not,
==,
......
......@@ -10,9 +10,22 @@ functor MkCPSPass (Core: CPSCORE) = struct
structure CM = CompilationMonad
val dumpFreeVars = ref false
val clicks = Stats.newCounter ("cps." ^ Core.name ^ ".clicks")
fun dumpPre (os, cps) = Pretty.prettyTo (os, CPS.PP.term cps)
val dumpFreeVars = fn cps =>
if !dumpFreeVars
then
let
open Layout Pretty
in
FreeVars.run cps
;align [str "freevars=",indent 2 (FreeVars.layout())]
end
else Layout.str""
fun dumpPre (os, cps) =
Pretty.prettyTo (os, Layout.align [CPS.PP.term cps,dumpFreeVars cps])
fun dumpPost (os, t) = let
open Layout Pretty
fun prettyPass (cps, clicks) =
......@@ -21,7 +34,8 @@ functor MkCPSPass (Core: CPSCORE) = struct
[str "cps.", str Core.name, str ".clicks", str "=",
str (Int.toString clicks)],
CPS.PP.term cps,
align [str "census=", indent 2 (Census.layout())]]
align [str "census=", indent 2 (Census.layout())],
dumpFreeVars cps]
in
Pretty.prettyTo (os, prettyPass t)
end
......
......@@ -20,8 +20,6 @@ structure DesugarDecode = struct
end
val tok = Atom.atom "tok"
val consume = Atom.atom "consume"
val unconsume = Atom.atom "unconsume"
val slice = Atom.atom "slice"
val return = Atom.atom "return"
......@@ -34,6 +32,8 @@ structure DesugarDecode = struct
fun consumeTok () = let
val tok = freshTok ()
val tokSz = Int.toString(!granularity)
val consume = Atom.atom("consume"^tokSz)
val consume =
Exp.ID
(VarInfo.lookup
......@@ -43,6 +43,8 @@ structure DesugarDecode = struct
end
fun unconsumeTok () = let
val tokSz = Int.toString(!granularity)
val unconsume = Atom.atom("unconsume"^tokSz)
val unconsume =
Exp.ID
(VarInfo.lookup
......
......@@ -115,7 +115,33 @@ structure ASTSubst = struct
map (renameExp sigma) es)
| RECORDexp fs => RECORDexp (map (renameField sigma) fs)
| UPDATEexp fs => UPDATEexp (map (renameFieldOpt sigma) fs)
| SEQexp es => SEQexp (map (renameSeqexp sigma) es)
| SEQexp es =>
let
fun visitSeqexp sigma e =
case e of
MARKseqexp e => visitSeqexp sigma (#tree e)
| ACTIONseqexp e => ACTIONseqexp (renameExp sigma e)
| BINDseqexp (x, e) =>
(* {x} was renamed so we just have to
* substitute it here *)
BINDseqexp (Subst.apply sigma x, renameExp sigma e)
fun previsit (t, sigma) =
case t of
MARKseqexp t => previsit (#tree t,sigma)
| BINDseqexp (x, e) =>
let
val x' = copy x
val sigma = extend sigma x' x
in
sigma
end
| _ => sigma
val sigma = foldl previsit sigma es
in
SEQexp (map (visitSeqexp sigma) es)
end
| FNexp (xs, e) =>
let
val xs' = copyAll xs
......@@ -152,17 +178,6 @@ structure ASTSubst = struct
and renameCase sigma (pat, e) = (pat, renameExp sigma e)
and renameField sigma (f, e) = (f, renameExp sigma e)
and renameFieldOpt sigma (f, eOpt) = (f, Option.map (renameExp sigma) eOpt)
and renameSeqexp sigma t =
case t of
MARKseqexp t => renameSeqexp sigma (#tree t)
| ACTIONseqexp e => ACTIONseqexp (renameExp sigma e)
| BINDseqexp (x, e) =>
let
val x' = copy x
val sigma = extend sigma x' x
in
BINDseqexp (x', renameExp sigma e)
end
end
end
......@@ -180,7 +195,6 @@ end = struct
open T
val map = ref ds
val varmap = !SymbolTables.varTable
fun inline (x, exp) =
case Map.find (!map, x) of
NONE =>
......
......@@ -132,22 +132,24 @@ functor MkAst (Core: AST_CORE) = struct
seq [str "type", space, syn_bind t, space, ty tyexp]
| DATATYPEdecl (t, decls) =>
align
[seq [str "type", space, con_bind t],
[seq [str "datatype", space, con_bind t],
indent 3 (alignPrefix (map condecl decls, "| "))]
| DECODEdecl (n, ps, Sum.INL e) =>
align [seq [str "fn ", var_bind n, space, decodepats ps],
indent 1 (block e)]
align
[seq
[str "val", space, var_bind n, space, decodepats ps, is],
indent 3 (exp e)]
| DECODEdecl (n, ps, Sum.INR ges) =>
align
[seq
[str "fn ", var_bind n, space, decodepats ps],
indent 1
(align
[str "val", space, var_bind n, space, decodepats ps, is],
indent 3
(alignPrefix
(map
(fn (e1, e2) =>
align [seq [exp e1, str ":"],
indent 1 (block e2)])
ges))]
seq [exp e1, is, space, exp e2])
ges,
"| "))]
| LETRECdecl d => recdecl d
and decodepats ps =
......@@ -205,51 +207,54 @@ functor MkAst (Core: AST_CORE) = struct
| STRlit s => str s
| VEClit s => seq [str "'", str s, str "'"]
and block t = align [seq [lb, exp t], rb]
and exp t =
case t of
MARKexp t' => exp (#tree t')
| LETRECexp (ds, e) =>
align [align (map recdecl ds),
exp e]
align
[align [str "let", indent 3 (align (map recdecl ds))],
align [str "in", indent 3 (exp e)]]
| IFexp (iff, thenn, elsee) =>
align [seq [str "if", space, lp, exp iff, rp],
indent 1 (block thenn),
str "else",
indent 1 (block elsee)]
align
[align
[seq [str "if", space, exp iff],
indent 3 (align [str "then", indent 3 (exp thenn)])],
align [str "else", indent 3 (exp elsee)]]
| CASEexp (e, cs) =>
align
[seq [str "case", space, lp, exp e, rp],
(indent 1 (align [seq [lb, align (map casee cs)],
rb]))]
[seq [str "case", space, exp e, str "of"],
indent 3 (alignPrefix (map casee cs, "| "))]
| BINARYexp (e1, opid, e2) =>
seq [exp e1, space, infixop opid, space, exp e2]
| APPLYexp (e1, [e2 as APPLYexp _]) =>
seq [exp e1, space, lp, exp e2, rp]
| APPLYexp (e1, es) => seq [exp e1, args (map exp es)]
seq [infixop opid, space, exp e1, space, exp e2]
| APPLYexp (e1, es) => seq [exp e1, space, seq (separate (map exp es," "))]
| RECORDexp fs => listex "{" "}" "," (map field fs)
| SELECTexp f => seq [str "$", field_use f]
| UPDATEexp fs => seq [str "@", listex "{" "}" "," (map fieldOpt fs)]
| LITexp l => lit l
| SEQexp ss => align (separateRight (map seqexp ss, ";"))
| SEQexp ss =>
align
[align
[str "do",
indent 3 (align (separateRight (map seqexp ss, ";")))],
str "end"]
| IDexp id => var_use id
| CONexp con => con_use con
| FNexp (xs, e) => seq [args (map var_bind xs), indent 1 (block e)]
and args x = seq [space, listex "" "" "," x]
| FNexp (xs, e) => seq [str "\\", args xs, str ".", exp e]
and infixop t =
case t of
MARKinfixop t' => infixop (#tree t')
| OPinfixop opid => op_id opid
and recdecl (n, args, e) =
and args xs = seq (separate (map var_bind xs, " "))
and recdecl (f, xs, e) =
align
[seq
[str "fn ", var_bind n, space,
seq (separate (map var_bind args, ", "))],
indent 1 (block e)]
[str "val", space,
var_bind f, space,
args xs, space, str "="],
indent 3 (exp e)]
and seqexp t =
case t of
......@@ -265,8 +270,8 @@ functor MkAst (Core: AST_CORE) = struct
and casee (p, e) =
align
[seq [pat p, str ":"],
indent 1 (block e)]
[seq [pat p, space, str ":"],
indent 3 (exp e)]
and def (nameAndArgs, body) = align [nameAndArgs, indent 2 body]
......
......@@ -89,10 +89,20 @@ structure Primitives = struct
flow = noFlow},
{name="false", ty=VEC (CONST 1),
flow = noFlow},
{name="consume", ty=MONAD (VEC size,stateA, stateA'),
{name="consume8", ty=MONAD (VEC size,stateA, stateA'),
flow = BD.meetVarZero (bvar size) o
BD.meetVarImpliesVar (bvar stateA', bvar stateA)},
{name="unconsume", ty=MONAD (UNIT,stateB, stateB'),
{name="unconsume8", ty=MONAD (UNIT,stateB, stateB'),
flow = BD.meetVarImpliesVar (bvar stateB', bvar stateB)},
{name="consume16", ty=MONAD (VEC size,stateA, stateA'),
flow = BD.meetVarZero (bvar size) o
BD.meetVarImpliesVar (bvar stateA', bvar stateA)},
{name="unconsume16", ty=MONAD (UNIT,stateB, stateB'),
flow = BD.meetVarImpliesVar (bvar stateB', bvar stateB)},
{name="consume32", ty=MONAD (VEC size,stateA, stateA'),
flow = BD.meetVarZero (bvar size) o
BD.meetVarImpliesVar (bvar stateA', bvar stateA)},
{name="unconsume32", ty=MONAD (UNIT,stateB, stateB'),
flow = BD.meetVarImpliesVar (bvar stateB', bvar stateB)},
{name="slice", ty=MONAD (freshVar (),stateC, stateC'),
flow = BD.meetVarImpliesVar (bvar stateC', bvar stateC)},
......@@ -177,10 +187,20 @@ structure Primitives = struct
flow = BD.meetVarZero (bvar s17) o
BD.meetVarZero (bvar s18) o
BD.meetVarZero (bvar s19)},
{name="%consume", ty=MONAD (VEC size,stateJ, stateJ'),
{name="%consume8", ty=MONAD (VEC size,stateJ, stateJ'),
flow = BD.meetVarZero (bvar size) o
BD.meetVarImpliesVar (bvar stateJ', bvar stateJ)},
{name="%unconsume8", ty=MONAD (UNIT,stateK, stateK'),
flow = BD.meetVarImpliesVar (bvar stateK', bvar stateK)},
{name="%consume16", ty=MONAD (VEC size,stateJ, stateJ'),
flow = BD.meetVarZero (bvar size) o
BD.meetVarImpliesVar (bvar stateJ', bvar stateJ)},
{name="%unconsume16", ty=MONAD (UNIT,stateK, stateK'),
flow = BD.meetVarImpliesVar (bvar stateK', bvar stateK)},
{name="%consume32", ty=MONAD (VEC size,stateJ, stateJ'),
flow = BD.meetVarZero (bvar size) o
BD.meetVarImpliesVar (bvar stateJ', bvar stateJ)},
{name="%unconsume", ty=MONAD (UNIT,stateK, stateK'),
{name="%unconsume32", ty=MONAD (UNIT,stateK, stateK'),
flow = BD.meetVarImpliesVar (bvar stateK', bvar stateK)},
{name="%slice", ty=MONAD (freshVar (),stateL, stateL'),
flow = BD.meetVarImpliesVar (bvar stateL', bvar stateL)}
......
/* vim:cindent:ts=2:sw=2:expandtab */
#include <dis.h>
int main (int argc, char** argv) {
......@@ -10,12 +12,13 @@ int main (int argc, char** argv) {
int x = fscanf(stdin,"%x",&c);
switch (x) {
case EOF:
break;
goto done;
case 0:
__fatal("invalid input, should be in hex form: '0f 0b ..'");
}
blob[i] = c & 0xff;
}
done:
__decode(__decode__,blob,i,&insn);