Up.

detail/codegen/c0/runtime.c

@@ -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;

detail/codegen/c0/runtime.h

@@ -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);

detail/cps/cps-opt.sml

@@ -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 =

detail/cps/from-core.sml

@@ -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,
           ==,

detail/cps/mk-cps-pass.sml

@@ -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

detail/desugar/desugar-decode-syntax.sml

@@ -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

detail/desugar/inline-decode-patterns.sml

@@ -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 =>

detail/parser/mk-ast.sml

@@ -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]
 

detail/semantic/primitives.sml

@@ -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)}

examples/x86/cli-println.c

 
+/* 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);