Commit 64223137 authored by mb0's avatar mb0
Browse files

Merge upstream.

parent 82118c7e
......@@ -28,7 +28,7 @@ structure Closure = struct
| FASTCC of
{k: Var.c,
xs: Var.v list}
| CASE of Var.v * (tag list * block) list
| CASE of casety * Var.v * (tag list * block) list
and stmt =
LETVAL of Var.v * cval
......@@ -55,6 +55,7 @@ structure Closure = struct
flow: term}
withtype branch = Var.c * Var.v list
and casety = CPS.Exp.casety
end
structure Block = struct
......@@ -113,10 +114,17 @@ structure Closure = struct
seq [var k, vars (closure::k::xs)]
| FASTCC {k, xs} =>
seq [var k, vars (k::xs)]
| CASE (x, ks) =>
align
[seq [str "case", space, var x, space, str "of"],
cases ks]
| CASE (ty, x, ks) =>
let
val casee =
case ty of
CPS.Exp.CASETYCON => "con case"
| CPS.Exp.CASETYVEC => "vec case"
| CPS.Exp.CASETYINT => "int case"
in
align [seq [str "case", space, var x, space, str "of"],
cases ks]
end
and stmt s =
case s of
......
......@@ -288,9 +288,9 @@ end = struct
flow=Clos.CC {k=k', closure=k, xs= !xs'}}
end
end
| CASE (x, ks) =>
| CASE (ty, x, ks) =>
{stmts=[],
flow=Clos.CASE (Subst.apply sigma x, convCases sigma ks)}
flow=Clos.CASE (ty, Subst.apply sigma x, convCases sigma ks)}
and convCases sigma ks = map (fn (tag, c) => (tag, convCase sigma c)) ks
and convCase sigma (k, xs) =
......
......@@ -28,7 +28,16 @@ structure PrettyC = struct
fun call (f, xs) = seq [var f, args xs]
fun comment t = seq [str "/*", t, str "*/"]
fun define (x, v) = seq [str "#define", space, x, space, v]
fun caseTag x = seq [str "__CASETAG", args [x]]
fun caseTag ty x =
let
val casetag =
case ty of
CPS.Exp.CASETYCON => "__CASETAGCON"
| CPS.Exp.CASETYVEC => "__CASETAGVEC"
| CPS.Exp.CASETYINT => "__CASETAGINT"
in
seq [str casetag, args [x]]
end
fun return x = seq [str "return", space, lp, x, rp, str ";"]
fun switch (x, cases, dflt) =
align
......@@ -254,7 +263,7 @@ structure C = struct
PrettyC.return (PrettyC.invoke (k, closure::xs))
| FASTCC {k, xs} =>
PrettyC.return (PrettyC.fastinvoke (k, xs))
| CASE (x, cs) =>
| CASE (ty, x, cs) =>
let
val cs' = List.filter (fn (cs, _) => not (null cs)) cs
val dflt = List.find (fn (cs, _) => null cs) cs
......@@ -265,7 +274,7 @@ structure C = struct
| SOME (_, block) => emitBlock block
in
PrettyC.switch
(PrettyC.caseTag x, map emitCase cs', dflt)
(PrettyC.caseTag ty x, map emitCase cs', dflt)
end
and emitCase (cs, block) = PrettyC.casee (cs, emitBlock block)
......
......@@ -309,6 +309,10 @@ __obj __eval (__obj (*f)(__obj,__obj), __char* blob, __word sz) {
return (__runWithState(f,s));
}
__obj __evalPure (__obj (*f)(__obj,__obj), __obj x) {
return (__runWithState(f,x));
}
/* Caller needs to reset the heap with `__resetHeap()` */
__word __decode (__obj (*f)(__obj,__obj), __char* blob, __word sz, __obj* insn) {
__obj o = __eval(f,blob,sz);
......
......@@ -356,6 +356,12 @@ static inline __word __CASETAG (__obj o) {
}
}
static inline __word __CASETAGCON (__obj o) { return o->tagged.tag; }
static inline __word __CASETAGVEC (__obj o) { return o->bv.vec; }
static inline __word __CASETAGINT (__obj o) { return o->z.value; }
static inline int __isTrue (__obj o) {
return (o == __TRUE); /* TODO: or isBitVec(o)&&value='1' */
}
......@@ -391,6 +397,7 @@ __obj __printState();
int ___isNil(__obj);
__obj __runWithState(__obj(*)(__obj,__obj),__obj);
__obj __evalPure(__obj(*)(__obj,__obj),__obj);
__obj __eval(__obj(*)(__obj,__obj),__char*, __word);
__word __decode(__obj(*)(__obj,__obj),__char*,__word,__obj*);
__obj __translate(__obj(*)(__obj,__obj),__obj);
......
......@@ -70,6 +70,7 @@ structure Mangle = struct
| #"!" => "_ex_"
| #"*" => "_star_"
| #"-" => "_minus_"
| #"+" => "_plus_"
| #"^" => "_concat_"
| #"/" => "_slash_"
| #"?" => "_q_"
......
......@@ -92,7 +92,7 @@ structure JS0 = struct
end
| APP (f,k,xs) => rev (JSStmt.return (JSExp.call (id f, map id (k::xs)))::acc)
| CC (c,xs) => rev (JSStmt.return (JSExp.call (id c, map id xs))::acc)
| CASE (x,cs) =>
| CASE (ty,x,cs) =>
let
fun branch (k,xs) = Vector.fromList [JSStmt.return (JSExp.call (id k, map id xs))]
val cs' = List.filter (fn (cs, _) => not (null cs)) cs
......@@ -102,11 +102,22 @@ structure JS0 = struct
case dflt of
NONE => fatalDflt
| SOME (_, t) => branch t
val casetag =
case ty of
CPS.Exp.CASETYCON => "__casetagcon"
| CPS.Exp.CASETYVEC => "__casetagvec"
| CPS.Exp.CASETYINT => "__casetagint"
val giveExp =
case ty of
CPS.Exp.CASETYCON => JSExp.string o tagName o ConInfo.unsafeFromWord
| CPS.Exp.CASETYVEC => JSExp.word
| CPS.Exp.CASETYINT => JSExp.word
in
rev (JSStmt.switch
(JSExp.call (Id.fromString "__casetag", [id x]),
(JSExp.call (Id.fromString casetag, [id x]),
map (fn (cs, t) =>
(map JSExp.word cs, branch t)) cs',
(map giveExp cs, branch t)) cs',
dflt)::acc)
end
......
......@@ -3,11 +3,9 @@ var __TRUE = {sz:1, vec:1}
var __FALSE = {sz:1, vec:0}
var __UNIT = {}
function __halt (o) { return o; }
function __raise (o) { throw o; }
function __consume (s) {
function __consume8 (s) {
var blob = s.___blob;
var i = s.___idx;
var v = blob[i];
......@@ -16,12 +14,46 @@ function __consume (s) {
return {___1:{vec:v,sz:8}, ___2:ss}
}
function __unconsume (s) {
function __unconsume8 (s) {
var ss = s; // FIXME: destructive update!
ss.___idx = s.___idx-1;
return {___1:__UNIT, ___2:ss};
}
function __consume16 (s) {
var blob = s.___blob;
var i = s.___idx;
var v1 = blob[i];
var v2 = blob[i+1]<<8;
var ss = s; // FIXME: destructive update!
ss.___idx = i+1;
return {___1:{vec:(v1|v2)&0xffff,sz:8}, ___2:ss}
}
function __unconsume16 (s) {
var ss = s; // FIXME: destructive update!
ss.___idx = s.___idx-2;
return {___1:__UNIT, ___2:ss};
}
function __consume32 (s) {
var blob = s.___blob;
var i = s.___idx;
var v1 = blob[i];
var v2 = blob[i+1]<<8;
var v3 = blob[i+2]<<16;
var v4 = blob[i+3]<<24;
var ss = s; // FIXME: destructive update!
ss.___idx = i+1;
return {___1:{vec:(v1|v2|v3|v4)&0xffffffff,sz:8}, ___2:ss}
}
function __unconsume32 (s) {
var ss = s; // FIXME: destructive update!
ss.___idx = s.___idx-4;
return {___1:__UNIT, ___2:ss};
}
function __slice (tok, offs, sz) {
var tokk = tok.vec;
var x = ((tokk>>offs) & ((1<<sz)-1));
......@@ -36,6 +68,18 @@ function __concat (a, b) {
return {sz:szOfA+szOfB, vec:aa << szOfB | bb};
}
function __concatstring (a, b) {
return a + b;
}
function __showbitvec (x) {
return '0x' + x.vec.toString(16);
}
function __showint (x) {
return x.toString();
}
function __equal (a, b) {
var aa = a.vec;
var bb = b.vec;
......@@ -66,11 +110,28 @@ function __casetag (obj) {
throw '__CASETAG() applied to non-tagged object'
}
function __casetagcon (obj) { return obj.tag };
function __casetagvec (obj) { return obj.vec };
function __casetagint (obj) { return obj };
function __halt (o) { return o; }
function __eval (f, blob) {
var s = {___blob:blob, ___idx:0};
return f(__halt,s);
}
function __evalPure (f, x) {
return f(__halt,x);
}
function __eval2 (f, x, state) {
function k (kk) { kk(state) };
return f(k,x);
}
function toBytes (str) {
function toByte (c) {
switch (c) {
......@@ -104,17 +165,17 @@ function toBytes (str) {
}
function prettyJSON (o) {
print(JSON.stringify(o));
return JSON.stringify(o);
}
function decode64 (str) {
var blob = toBytes(str);
var s = __eval(__decode__,blob);
return(s.___1);
function pretty (i) {
return __evalPure(__pretty__,i);
}
function decodeAndPrint (str) {
prettyJSON(decode64(str));
function decode (str) {
var blob = toBytes(str);
var s = __eval(__decode__,blob);
return s.___1;
}
@functions@
......@@ -55,7 +55,7 @@ structure CheckDefUse = struct
;use k
;app use ys)
| CC (k, xs) => (use k; app use xs)
| CASE (x, ks) => (use x; app (visitMatch n) ks)
| CASE (_, x, ks) => (use x; app (visitMatch n) ks)
and visitMatch n (_, (k, xs)) = (use k; app use xs)
......@@ -173,7 +173,7 @@ structure Census = struct
;update (E n) k
;app (update (E n)) ys)
| CC (k, xs) => (update (A n) k; app (update (E n)) xs)
| CASE (x, ks) => (update (E n) x; app (visitMatch n) ks)
| CASE (_, x, ks) => (update (E n) x; app (visitMatch n) ks)
and visitMatch n (_, (k, xs)) = (update (A n) k; app (update (E n)) xs)
......@@ -349,7 +349,7 @@ structure FreeVars = struct
in
env
end
| CASE (x, ks) =>
| CASE (_, x, ks) =>
let
val env = use env x
val env =
......@@ -498,9 +498,10 @@ structure Subst = struct
apply sigma k,
applyAll sigma xs)
| CC (k, xs) => CC (apply sigma k, applyAll sigma xs)
| CASE (x, ks) =>
| CASE (ty, x, ks) =>
CASE
(apply sigma x,
(ty,
apply sigma x,
map
(fn (tags, (k, xs)) =>
(tags, (apply sigma k, applyAll sigma xs))) ks)
......@@ -652,7 +653,7 @@ structure Rec = struct
env
end
| LETVAL (x, v, t) => unuse (visitCVal (v, visitTerm (t, env))) x
| CASE (x, ks) =>
| CASE (_, x, ks) =>
let
val env = use env x
val env = visitCases (ks, env)
......@@ -910,7 +911,7 @@ structure Cost = struct
foldl
(fn ((_, _, _, body), n) =>
lp (body, n)) (lp (body, inc n RECS (length ds))) ds
| CASE (_, cs) => inc n CASES (length cs)
| CASE (_, _, cs) => inc n CASES (length cs)
| APP _ => inc n APPS 1
| CC _ => inc n CCS 1
val ZERO = {cases=0,conts=0,recs=0,apps=0,ccs=0}
......@@ -1022,9 +1023,10 @@ end = struct
simplify env sigma t)
| CC (k, xs) =>
CC (Subst.apply sigma k, Subst.applyAll sigma xs)
| CASE (x, cs) =>
| CASE (ty, x, cs) =>
CASE
(Subst.apply sigma x,
(ty,
Subst.apply sigma x,
map
(fn (tags,(k,xs)) =>
(tags,(Subst.apply sigma k, Subst.applyAll sigma xs))) cs)
......@@ -1115,9 +1117,10 @@ structure HoistFun = struct
simplify env sigma t)
| CC (k, xs) =>
CC (Subst.apply sigma k, Subst.applyAll sigma xs)
| CASE (x, cs) =>
| CASE (ty, x, cs) =>
CASE
(Subst.apply sigma x,
(ty,
Subst.apply sigma x,
map
(fn (tags,(k,xs)) =>
(tags,(Subst.apply sigma k, Subst.applyAll sigma xs))) cs)
......@@ -1375,9 +1378,10 @@ structure BetaContFun = struct
Subst.apply sigma y,
map (fn (f, z) => (f, Subst.apply sigma z)) fs,
simplify env sigma t)
| CASE (x, cs) =>
| CASE (ty, x, cs) =>
CASE
(Subst.apply sigma x,
(ty,
Subst.apply sigma x,
map
(fn (tags,(k,xs)) =>
(tags,(Subst.apply sigma k, Subst.applyAll sigma xs))) cs)
......@@ -1574,7 +1578,7 @@ structure BetaContract = struct
Subst.apply sigma y,
map (fn (f, z) => (f, Subst.apply sigma z)) fs,
simplify env sigma t)
| CASE (x, cs) =>
| CASE (ty, x, cs) =>
let
val x = Subst.apply sigma x
val cs =
......@@ -1587,7 +1591,7 @@ structure BetaContract = struct
fun boundTag (tags, _) = List.exists matchh tags
in
case List.find boundTag cs of
NONE => CASE (x, cs)
NONE => CASE (ty, x, cs)
| SOME (_,(k,xs)) => (click();CC (k, xs))
end
| LETREC (ds, L) =>
......@@ -1713,9 +1717,10 @@ structure BetaContFunShrink = struct
Subst.apply sigma y,
map (fn (f, z) => (f, Subst.apply sigma z)) fs,
simplify sigma t)
| CASE (x, cs) =>
| CASE (ty, x, cs) =>
CASE
(Subst.apply sigma x,
(ty,
Subst.apply sigma x,
map
(fn (tags,(k,xs)) =>
(tags,(Subst.apply sigma k, Subst.applyAll sigma xs))) cs)
......
......@@ -26,7 +26,7 @@ structure CPS = struct
| LETUPD of Var.v * Var.v * (field * Var.v) list * term
| APP of Var.v * Var.c * Var.v list
| CC of Var.c * Var.v list
| CASE of Var.v * (tag list * branch) list
| CASE of casety * Var.v * (tag list * branch) list
and cval =
FN of Var.c * Var.v list * term
......@@ -39,6 +39,11 @@ structure CPS = struct
| VEC of string
| UNT
and casety =
CASETYCON
| CASETYVEC
| CASETYINT
withtype recdecl = Var.v * Var.c * Var.v list * term
and contdecl = Var.c * Var.v list * term
and branch = Var.c * Var.v list
......@@ -158,10 +163,17 @@ structure CPS = struct
align
[align [str "letcont", indent 3 (contdecls cs)],
align [str "in", indent 3 (term body)]]
| CASE (v, ks) =>
align
[seq [str "case", space, var v, space, str "of"],
cases ks]
| CASE (ty, v, ks) =>
let
val casee =
case ty of
CASETYCON => "con case"
| CASETYVEC => "vec case"
| CASETYINT => "int case"
in
align [seq [str casee, space, var v, space, str "of"],
cases ks]
end
| APP (f, c, xs) => seq [var f, vars (c::xs)]
| CC (c, vs) => seq [cvar c, vars vs]
and vars xs = seq [lp, seq (separate (map var xs, ",")), rp]
......
......@@ -48,10 +48,41 @@ end = struct
val raisee = get "raise"
val return = get "return"
val add = get "+"
val concatstring = get "+++"
val showbitvec = get "showbitvec"
val showint = get "showint"
val sub = get "-"
val sx = get "sx"
val zx = get "zx"
val concatstring =
let
val a = fresh "a"
val b = fresh "b"
val prim = get "%concatstring"
val body = PRI (prim, [a, b])
in
(concatstring, [a,b], body)
end
val showbitvec =
let
val x = fresh "x"
val prim = get "%showbitvec"
val body = PRI (prim, [x])
in
(showbitvec, [x], body)
end
val showint =
let
val x = fresh "x"
val prim = get "%showint"
val body = PRI (prim, [x])
in
(showint, [x], body)
end
val sx =
let
val x = fresh "x"
......@@ -228,6 +259,9 @@ end = struct
unconsume16,
consume32,
unconsume32,
concatstring,
showbitvec,
showint,
andd,
not,
==,
......@@ -321,6 +355,7 @@ end = struct
kappa
| CASE (e, ps) =>
let
val ty = guessPatTy e ps
val j = fresh continuation
fun trans z ps cps ks =
case ps of
......@@ -337,7 +372,7 @@ end = struct
| _ =>
Exp.LETCONT
((j, [x], kappa x)::cps,
Exp.CASE (z, ks))
Exp.CASE (ty, z, ks))
end
| (p, e)::ps =>
let
......@@ -494,6 +529,17 @@ end = struct
lp (S.full str, [])) strs)
end
and guessPatTy e ps =
let
open Core.Pat
in
case #1 (hd ps) of
CON _ => Exp.CASETYCON
| BIT _ => Exp.CASETYVEC
| INT _ => Exp.CASETYINT
| _ => Exp.CASETYINT (* FIXME *)
end
and transPat p k ks =
let (* TODO: apply arguments to the branches *)
(* TODO: check size of generated patterns and bail out if to large *)
......@@ -550,6 +596,7 @@ end = struct
kont
| CASE (e, ps) =>
let
val ty = guessPatTy e ps
fun trans z ps cps ks =
case ps of
(p, e)::ps =>
......@@ -568,7 +615,7 @@ end = struct
[([],body)] =>
Exp.LETCONT (cps, Exp.CC body)
| _ =>
Exp.LETCONT (cps, Exp.CASE (z, ks))
Exp.LETCONT (cps, Exp.CASE (ty, z, ks))
in
trans0 e (fn z => trans z ps [] [])
end
......
......@@ -132,7 +132,7 @@ functor MkAst (Core: AST_CORE) = struct
seq [str "type", space, syn_bind t, space, ty tyexp]
| DATATYPEdecl (t, decls) =>
align
[seq [str "datatype", space, con_bind t],
[seq [str "type", space, con_bind t],
indent 3 (alignPrefix (map condecl decls, "| "))]
| DECODEdecl (n, ps, Sum.INL e) =>
align
......@@ -204,7 +204,7 @@ functor MkAst (Core: AST_CORE) = struct
case t of
INTlit i => int i
| FLTlit f => str (FloatLit.toString f)
| STRlit s => str s
| STRlit s => seq [str "\"", str s, str "\""]
| VEClit s => seq [str "'", str s, str "'"]
and exp t =
......@@ -225,7 +225,7 @@ functor MkAst (Core: AST_CORE) = struct
[seq [str "case", space, exp e, str "of"],
indent 3 (alignPrefix (map casee cs, "| "))]
| BINARYexp (e1, opid, e2) =>
seq [infixop opid, space, exp e1, space, exp e2]
seq [exp e1, space, infixop opid, 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]
......
......@@ -253,11 +253,18 @@ ApplyExp
AtomicExp
: Lit => (mark PT.MARKexp (FULL_SPAN, PT.LITexp Lit))
| Qid => (mark PT.MARKexp (FULL_SPAN, PT.IDexp Qid))
(* | path=("." Qid)+ => (foldl (fn (fld,e) => PT.APPLYexp (PT.SELECTexp fld, [e])) AtomicExp path) *)
| Qid ("." Qid)+ => (foldl (fn (fld,e) => PT.APPLYexp (PT.SELECTexp fld, [e])) (PT.IDexp Qid) SR)
| ConUse => (mark PT.MARKexp (FULL_SPAN, PT.CONexp ConUse))
| "@" "{" Field ("," Field)* "}" =>
(mark PT.MARKexp (FULL_SPAN, PT.UPDATEexp (Field::SR)))