Merge upstream.

detail/closure/from-cps.sml

@@ -9,7 +9,7 @@ end = struct
    structure FV = FreeVars
    structure FI = FunInfo
    structure Map = SymMap
-   structure Set = SymSet
+   structure Set = FreeVars.Set
    structure Clos = Closure.Stmt
 
    val closure = Atom.atom "env"

detail/codegen/c0/c0.sml

@@ -53,13 +53,7 @@ structure PrettyC = struct
       in
          seq [str "__INVOKE", i n, args (f::xs)]
       end
-   fun fastinvoke (f, xs) =
-      let
-         val n = List.length xs
-         val i = str o Int.toString
-      in
-         seq [str "__CALL", i n, args (f::xs)]
-      end
+   fun fastinvoke (f, xs) = seq [str "__FCALL", args (f::xs)]
 end
 
 structure C0Templates = struct
@@ -100,6 +94,7 @@ structure C = struct
    fun codegen spec =
       let
          open Layout Pretty
+         val () = Mangle.reset()
          val clos = Spec.get#declarations spec
          val exports = Spec.get#exports spec
          fun exported f =

detail/codegen/c0/runtime.c

@@ -56,6 +56,16 @@ __obj __add (__obj A, __obj B) {
   return (x);
 }
 
+__obj __sub (__obj A, __obj B) {
+  __word a = A->z.value;
+  __word b = B->z.value;
+  __LOCAL0(x);
+    __INT_BEGIN(x);
+    __INT_INIT(a - b);
+    __INT_END(x);
+  return (x);
+}
+
 /* FIXME */
 __obj __sx (__obj x) {
   __LOCAL0(y);
@@ -185,7 +195,7 @@ __obj __runWithState (__obj (*f)(__obj,__obj), __obj s) {
     __CLOSURE_BEGIN(envK,1)
     __CLOSURE_ADD(k);
     __CLOSURE_END(envK,1);
-  return (__CALL2(f,envK,s));
+  return (__FCALL(f,envK,s));
 }
 
 __obj __eval (__obj (*f)(__obj,__obj), __char* blob, __word sz) {
@@ -226,7 +236,8 @@ __obj __cont (__obj env, __obj f) {
     __CLOSURE_BEGIN(envK,1)
     __CLOSURE_ADD(k);
     __CLOSURE_END(envK,1);
-  return (__INVOKE2(f,envK,s));
+  __LOCAL(ff,__CLOSURE_REF(f,0));
+  return (__INVOKE3(ff,f,envK,s));
 }
 
 __obj __translate (__obj (*f)(__obj,__obj), __obj insn) {
@@ -239,10 +250,11 @@ __obj __translate (__obj (*f)(__obj,__obj), __obj insn) {
     __LABEL_END(k);
   __LOCAL0(envK);
     __CLOSURE_BEGIN(envK,2)
-    __CLOSURE_ADD(k);
     __CLOSURE_ADD(s);
+    __CLOSURE_ADD(k);
     __CLOSURE_END(envK,2);
-  return (__CALL2(f,envK,insn));
+  __LOCAL(ss, __FCALL(f,envK,insn));
+  return (__RECORD_SELECT(ss,___1));
 }
 
 const __char* __fieldName (__word i) {

detail/codegen/c0/runtime.h

@@ -37,24 +37,7 @@
 #define __INVOKE7(o, closure, u, v, w, x, y, z)\
   ((__obj(*)(__obj,__obj,__obj,__obj,__obj,__obj,__obj))((o)->label.f))(closure, u, v, w, x, y, z)
 
-#define __CALL1(f,x)\
-  f(x)
-#define __CALL2(f,x,y)\
-  f(x,y)
-#define __CALL3(f,x,y,z)\
-  f(x,y,z)
-#define __CALL4(f,w,x,y,z)\
-  f(w,x,y,z)
-#define __CALL5(f,v,w,x,y,z)\
-  f(v,w,x,y,z)
-#define __CALL6(f,u,v,w,x,y,z)\
-  f(u,v,w,x,y,z)
-#define __CALL7(f,t,u,v,w,x,y,z)\
-  f(t,u,v,w,x,y,z)
-#define __CALL8(f,s,t,u,v,w,x,y,z)\
-  f(s,t,u,v,w,x,y,z)
-#define __CALL9(f,r,s,t,u,v,w,x,y,z)\
-  f(r,s,t,u,v,w,x,y,z)
+#define __FCALL(f,...) f(__VA_ARGS__)
 
 /** ## Integers */
 
@@ -393,6 +376,7 @@ __obj __and(__obj,__obj);
 __obj __sx(__obj);
 __obj __zx(__obj);
 __obj __add(__obj,__obj);
+__obj __sub(__obj,__obj);
 __obj __raise(__obj);
 __obj __not(__obj);
 __obj __isNil(__obj);

detail/codegen/codegen-mangle.sml

@@ -8,9 +8,14 @@ structure Mangle = struct
    val variables = SymbolTables.varTable
    val fields = SymbolTables.fieldTable
    val constructors = SymbolTables.conTable
+
    val names = ref Map.empty : string Map.map ref
    val revnames = ref Map.empty : string Map.map ref
    val stamp = ref 0
+   fun reset () =
+      (names := Map.empty
+      ;revnames := Map.empty
+      ;stamp := 0)
 
    fun getStringOfPrim sym = Atom.toString (VI.getAtom(!variables, sym))
 

detail/codegen/js0/js0.sml

@@ -57,6 +57,7 @@ structure JS0 = struct
 
    fun codegen cpsSpec =
       let
+         val () = Mangle.reset()
          fun id s = Id.fromString (Mangle.apply s)
          fun field f = PropertyName.fromString (Mangle.applyField f)
          fun fieldId f = Id.fromString (Mangle.applyField f)

detail/common/pp.sml

@@ -26,6 +26,9 @@ structure Pretty = struct
    fun symset item t =
       L.listex "{" "}" ";"
          (List.map item (SymSet.listItems t))
+   fun symlistset item t =
+      L.listex "{" "}" ";"
+         (List.map item (SymListSet.listItems t))
    fun pretty layout = Layout.print (layout, print)
    fun prettyTo (os, layout) = Layout.print (layout, fn s => TextIO.output (os, s))
 end

detail/cps/cps-opt.sml

@@ -216,7 +216,7 @@ end
 (* Currently `FreeVars` is br0k3n considering mutually recursive functions *)
 structure FreeVars = struct
    structure Map = SymMap
-   structure Set = SymSet
+   structure Set = SymListSet
    type t = Set.set Map.map
 
    val freevars = ref Map.empty : t ref
@@ -386,7 +386,7 @@ structure FreeVars = struct
    fun layout () =
       Pretty.symmap
          {key=CPS.PP.var,
-          item=Pretty.symset CPS.PP.var} (!freevars)
+          item=Pretty.symlistset CPS.PP.var} (!freevars)
       
    fun dump () = Pretty.prettyTo(TextIO.stdOut, layout())
 end

detail/cps/from-core.sml

@@ -44,6 +44,7 @@ end = struct
          val raisee = get "raise"
          val return = get "return"
          val add = get "+"
+         val sub = get "-"
          val sx = get "sx"
          val zx = get "zx"
 
@@ -77,6 +78,18 @@ end = struct
                (add, [a, b], body)
             end
 
+         (* val - a b = %sub(a,b) *)
+         val sub =
+            let
+               val a = fresh "a"
+               val b = fresh "b"
+               val primSub = get "%sub"
+               val body = PRI (primSub, [a, b])
+                     
+            in
+               (sub, [a, b], body)
+            end
+
          (* val and a b = %and(a,b) *)
          val andd =
             let
@@ -164,7 +177,18 @@ end = struct
                (unconsume, [s], body)
             end
       in
-         [slice, consume, unconsume, andd, not, ==, concat, raisee, add, sx, zx]
+         [slice,
+          consume,
+          unconsume,
+          andd,
+          not,
+          ==,
+          concat,
+          raisee,
+          add,
+          sx,
+          zx,
+          sub]
       end
 
    end

detail/desugar/inline-decode-patterns.sml

@@ -2,6 +2,18 @@
 (**
  * ## Inlining of decode patterns.
  *)
+structure VarAux = struct
+   val variables = SymbolTables.varTable
+   fun atomOf x = VarInfo.getAtom (!variables, x)
+   fun get s = VarInfo.lookup (!variables, Atom.atom s)
+   fun find s = VarInfo.find (!variables, Atom.atom s)
+   fun fresh variable = let
+      val (tab, sym) =
+         VarInfo.fresh (!variables, variable)
+   in
+      sym before SymbolTables.varTable := tab
+   end
+end
 
 structure ASTSubst = struct
    val empty = SymMap.empty
@@ -19,8 +31,8 @@ structure ASTSubst = struct
 
    fun copy x =
       let
-         val name = Aux.atomOf x
-         val x' = Aux.fresh name
+         val name = VarAux.atomOf x
+         val x' = VarAux.fresh name
       in
          x'
       end

detail/ml/smlnj/unsealed.cm

@@ -41,8 +41,10 @@ group is
    ../../semantic/primitives.sml
    ../../semantic/resolve-symbols.sml
    ../../semantic/resolve-type-info.sml
+
    ../../spec/core.sml
    ../../spec/spec.sml
+
    ../../desugar/desugar-control.sml
    ../../desugar/desugared-tree.sml
    ../../desugar/split-declarations.sml
@@ -53,16 +55,19 @@ group is
    ../../desugar/desugar-decode-syntax.sml
    ../../desugar/desugar-monadic-sequences.sml
    ../../desugar/desugar.sml
+
    ../../cps/cps.sml
    ../../cps/cps-control.sml
    ../../cps/from-core.sml
    ../../cps/cps-opt.sml
    ../../cps/mk-cps-pass.sml
    ../../cps/cps-passes.sml
+
    ../../closure/closure.sml
    ../../closure/closure-control.sml
    ../../closure/from-cps.sml
    ../../closure/closure-passes.sml
+
    ../../codegen/codegen-control.sml
    ../../codegen/codegen-mangle.sml
    ../../codegen/c0/c0.sml

detail/parser/spec.g

@@ -6,7 +6,6 @@
    | KW_in ("in")
    | KW_do ("do")
    | KW_export ("export")
-   | KW_div ("div")
    | KW_else ("else")
    | KW_end ("end")
    | KW_if ("if")
@@ -230,7 +229,6 @@ AExp
 MExp
    : SelectExp
       (( "*" => (mark PT.MARKinfixop (FULL_SPAN, PT.OPinfixop Op.times))
-       | "div" => (mark PT.MARKinfixop (FULL_SPAN, PT.OPinfixop Op.div))
        | "%" => (mark PT.MARKinfixop (FULL_SPAN, PT.OPinfixop Op.mod))
        ) ApplyExp =>
       (SR, SelectExp))* =>

detail/parser/spec.g.sml

@@ -47,13 +47,12 @@ SpecTokens = struct
       | KW_if
       | KW_end
       | KW_else
-      | KW_div
       | KW_export
       | KW_do
       | KW_in
       | KW_case
 
-    val allToks = [EOF, WILD, COLON, BAR, SEMI, COMMA, TILDE, SLASH, TIMES, MINUS, PLUS, CONCAT, RCB, LCB, RB, LB, RP, LP, DOT, TICK, EQ, BIND, SELECT, WITH, KW_or, KW_and, KW_type, KW_then, KW_raise, KW_granularity, KW_of, KW_mod, KW_val, KW_let, KW_if, KW_end, KW_else, KW_div, KW_export, KW_do, KW_in, KW_case]
+    val allToks = [EOF, WILD, COLON, BAR, SEMI, COMMA, TILDE, SLASH, TIMES, MINUS, PLUS, CONCAT, RCB, LCB, RB, LB, RP, LP, DOT, TICK, EQ, BIND, SELECT, WITH, KW_or, KW_and, KW_type, KW_then, KW_raise, KW_granularity, KW_of, KW_mod, KW_val, KW_let, KW_if, KW_end, KW_else, KW_export, KW_do, KW_in, KW_case]
 
     fun toString tok =
 (case (tok)
@@ -103,7 +102,6 @@ SpecTokens = struct
   | (KW_if) => "if"
   | (KW_end) => "end"
   | (KW_else) => "else"
-  | (KW_div) => "div"
   | (KW_export) => "export"
   | (KW_do) => "do"
   | (KW_in) => "in"
@@ -157,7 +155,6 @@ SpecTokens = struct
   | (KW_if) => false
   | (KW_end) => false
   | (KW_else) => false
-  | (KW_div) => false
   | (KW_export) => false
   | (KW_do) => false
   | (KW_in) => false
@@ -333,9 +330,7 @@ fun AExp_PROD_1_ACT (SR, MExp, SR_SPAN : (Lex.pos * Lex.pos), MExp_SPAN : (Lex.p
       mark PT.MARKexp (FULL_SPAN, mkLBinExp (MExp, SR)))
 fun MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_1_ACT (TIMES, SelectExp, TIMES_SPAN : (Lex.pos * Lex.pos), SelectExp_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) = 
   ( mark PT.MARKinfixop (FULL_SPAN, PT.OPinfixop Op.times))
-fun MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2_ACT (SelectExp, KW_div, SelectExp_SPAN : (Lex.pos * Lex.pos), KW_div_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) = 
-  ( mark PT.MARKinfixop (FULL_SPAN, PT.OPinfixop Op.div))
-fun MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_3_ACT (SelectExp, KW_mod, SelectExp_SPAN : (Lex.pos * Lex.pos), KW_mod_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) = 
+fun MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2_ACT (SelectExp, KW_mod, SelectExp_SPAN : (Lex.pos * Lex.pos), KW_mod_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) = 
   ( mark PT.MARKinfixop (FULL_SPAN, PT.OPinfixop Op.mod))
 fun MExp_PROD_1_SUBRULE_1_PROD_1_ACT (SR, SelectExp, ApplyExp, SR_SPAN : (Lex.pos * Lex.pos), SelectExp_SPAN : (Lex.pos * Lex.pos), ApplyExp_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)) = 
   (
@@ -614,10 +609,6 @@ fun matchKW_else strm = (case (lex(strm))
  of (Tok.KW_else, span, strm') => ((), span, strm')
   | _ => fail()
 (* end case *))
-fun matchKW_div strm = (case (lex(strm))
- of (Tok.KW_div, span, strm') => ((), span, strm')
-  | _ => fail()
-(* end case *))
 fun matchKW_export strm = (case (lex(strm))
  of (Tok.KW_export, span, strm') => ((), span, strm')
   | _ => fail()
@@ -947,8 +938,7 @@ and MonadicExp_NT (strm) = let
         (case (lex(strm))
          of (Tok.ID(_), _, strm') =>
               (case (lex(strm'))
-               of (Tok.KW_div, _, strm') => MonadicExp_PROD_1(strm)
-                | (Tok.KW_end, _, strm') => MonadicExp_PROD_1(strm)
+               of (Tok.KW_end, _, strm') => MonadicExp_PROD_1(strm)
                 | (Tok.KW_let, _, strm') => MonadicExp_PROD_1(strm)
                 | (Tok.KW_mod, _, strm') => MonadicExp_PROD_1(strm)
                 | (Tok.KW_and, _, strm') => MonadicExp_PROD_1(strm)
@@ -1117,27 +1107,18 @@ and MExp_NT (strm) = let
                             FULL_SPAN, strm')
                         end
                   fun MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2 (strm) = let
-                        val (KW_div_RES, KW_div_SPAN, strm') = matchKW_div(strm)
-                        val FULL_SPAN = (#1(KW_div_SPAN), #2(KW_div_SPAN))
-                        in
-                          (UserCode.MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2_ACT (SelectExp_RES, KW_div_RES, SelectExp_SPAN : (Lex.pos * Lex.pos), KW_div_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
-                            FULL_SPAN, strm')
-                        end
-                  fun MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_3 (strm) = let
                         val (KW_mod_RES, KW_mod_SPAN, strm') = matchKW_mod(strm)
                         val FULL_SPAN = (#1(KW_mod_SPAN), #2(KW_mod_SPAN))
                         in
-                          (UserCode.MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_3_ACT (SelectExp_RES, KW_mod_RES, SelectExp_SPAN : (Lex.pos * Lex.pos), KW_mod_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
+                          (UserCode.MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2_ACT (SelectExp_RES, KW_mod_RES, SelectExp_SPAN : (Lex.pos * Lex.pos), KW_mod_SPAN : (Lex.pos * Lex.pos), FULL_SPAN : (Lex.pos * Lex.pos)),
                             FULL_SPAN, strm')
                         end
                   in
                     (case (lex(strm))
                      of (Tok.KW_mod, _, strm') =>
-                          MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_3(strm)
+                          MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2(strm)
                       | (Tok.TIMES, _, strm') =>
                           MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_1(strm)
-                      | (Tok.KW_div, _, strm') =>
-                          MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2(strm)
                       | _ => fail()
                     (* end case *))
                   end
@@ -1151,8 +1132,7 @@ and MExp_NT (strm) = let
                 FULL_SPAN, strm')
             end
       fun MExp_PROD_1_SUBRULE_1_PRED (strm) = (case (lex(strm))
-             of (Tok.KW_div, _, strm') => true
-              | (Tok.KW_mod, _, strm') => true
+             of (Tok.KW_mod, _, strm') => true
               | (Tok.TIMES, _, strm') => true
               | _ => false
             (* end case *))

detail/parser/spec.l

@@ -97,7 +97,6 @@
 <INITIAL>"end" => (T.KW_end);
 <INITIAL>"do" => (T.KW_do);
 <INITIAL>"in" => (T.KW_in);
-<INITIAL>"div" => (T.KW_div);
 <INITIAL>"andalso" => (T.KW_and);
 <INITIAL>"orelse" => (T.KW_or);
 <INITIAL>"<-" => (T.BIND);

detail/semantic/symbol-table-type.sml

@@ -42,7 +42,7 @@ end
 
 structure SymbolTable :> SymbolTableSig = struct
 
-   val concisePrint : bool = true
+   val concisePrint : bool = false
 
    structure SymbolTable = IntRedBlackMap
    structure Reverse = AtomRedBlackMap
@@ -185,6 +185,7 @@ end
 
 structure SymMap = RedBlackMapFn(ord_symid)
 structure SymSet = RedBlackSetFn(ord_symid)
+structure SymListSet = ListSetFn(ord_symid)
 
 structure SpanMap = RedBlackMapFn(struct
    type ord_key = Error.span

examples/x86-ng.d

 granularity = 8
-export = / decode
+export = decode
 
 # Optional arguments
 #

examples/x86/Makefile

 
-all: ccmp ccli cxedcmp
+all: cmusl-cli
 
 ccmp:
 	gcc -O2 -Wall -static -I. -I../.. -I../../resources/xed/xed2-intel64/include -L../../resources/xed/xed2-intel64/lib -Wfatal-errors cmp.c ../../dis.c pretty.c -lbfd -liberty -ldl -lz -lxed -DRELAXEDFATAL -o cmp
 
 cxedcmp:
-	gcc -O2 -Wall -Wfatal-errors -static -I. -I../.. -I../../resources/xed/xed2-intel64/include -L../../resources/xed/xed2-intel64/lib xed-cmp.c ../../dis.c pretty.c -lbfd -liberty -ldl -lz -lxed -DRELAXEDFATAL -o xed-cmp
+	gcc -O2 -Wall -Wfatal-errors -static -I. -I../.. -I../../resources/xed/xed2-intel64/include -L../../resources/xed/xed2-intel64/lib xed-cmp.c pretty.c ../../dis.c -lbfd -liberty -ldl -lz -lxed -DRELAXEDFATAL -o xed-cmp
 
 ccli:
-	gcc -O2 -Wall -static -I. -I../.. -Wfatal-errors cli.c ../../dis.c pretty.c -DRELAXEDFATAL -o cli
+	gcc -pipe -O2 -Wall -static -I. -I../.. -Wfatal-errors cli.c pretty.c ../../dis.c -DRELAXEDFATAL -o cli
+
+cmusl-cli:
+	/usr/musl/bin/musl-gcc -pipe -O2 -Wall -static -I. -I../.. -Wfatal-errors cli.c pretty.c ../../dis.c -DRELAXEDFATAL -o musl-cli
 
 ccli-println:
 	gcc -O2 -Wall -static -I. -I../.. -Wfatal-errors cli-println.c ../../dis.c -DRELAXEDFATAL -o cli-println

examples/x86/cli.c

@@ -4,7 +4,7 @@
 
 int main (int argc, char** argv) {
   __char blob[15];
-  char fmt[128];
+  char fmt[1024];
   __word sz = 15;
   __obj insn,semantics;
   int i,c;
@@ -22,10 +22,11 @@ int main (int argc, char** argv) {
   if (___isNil(insn))
     __fatal("decode failed");
   else {
-    prettyln(insn,fmt,128);
+    prettyln(insn,fmt,1024);
     puts(fmt);
     semantics = __translate(__translate__,insn);
-    __println(semantics);
+    prettyln(semantics,fmt,1024);
+    puts(fmt);
   }
   return (1);
 }