AST-12 add debug_show

src/arrange.ml

@@ -13,6 +13,7 @@ let rec exp e = match e.it with
   | UnE (ot, uo, e)     -> "UnE"     $$ [operator_type !ot; unop uo; exp e]
   | BinE (ot, e1, bo, e2) -> "BinE"  $$ [operator_type !ot; exp e1; binop bo; exp e2]
   | RelE (ot, e1, ro, e2) -> "RelE"  $$ [operator_type !ot; exp e1; relop ro; exp e2]
+  | ShowE (ot, e)       -> "ShowE"   $$ [operator_type !ot; exp e]
   | TupE es             -> "TupE"    $$ List.map exp es
   | ProjE (e, i)        -> "ProjE"   $$ [exp e; Atom (string_of_int i)]
   | ObjE (s, efs)       -> "ObjE"    $$ [obj_sort s] @ List.map exp_field efs

src/arrange_ir.ml

@@ -14,6 +14,7 @@ let rec exp e = match e.it with
   | UnE (t, uo, e)      -> "UnE"     $$ [typ t; Arrange.unop uo; exp e]
   | BinE (t, e1, bo, e2)-> "BinE"    $$ [typ t; exp e1; Arrange.binop bo; exp e2]
   | RelE (t, e1, ro, e2)-> "RelE"    $$ [typ t; exp e1; Arrange.relop ro; exp e2]
+  | ShowE (t, e)        -> "ShowE"     $$ [typ t; exp e]
   | TupE es             -> "TupE"    $$ List.map exp es
   | ProjE (e, i)        -> "ProjE"   $$ [exp e; Atom (string_of_int i)]
   | DotE (e, n)         -> "DotE"    $$ [exp e; Atom (name n)]

src/async.ml

@@ -213,6 +213,8 @@ module Transform() = struct
     | VarE id -> exp'
     | UnE (ot, op, exp1) ->
       UnE (t_operator_type ot, op, t_exp exp1)
+    | ShowE (ot, exp1) ->
+      ShowE (t_operator_type ot, t_exp exp1)
     | BinE (ot, exp1, op, exp2) ->
       BinE (t_operator_type ot, t_exp exp1, op, t_exp exp2)
     | RelE (ot, exp1, op, exp2) ->

src/await.ml

@@ -67,6 +67,8 @@ and t_exp' context exp' =
     BinE (ot, t_exp context exp1, op, t_exp context exp2)
   | RelE (ot, exp1, op, exp2) ->
     RelE (ot, t_exp context exp1, op, t_exp context exp2)
+  | ShowE (ot, exp1) ->
+    ShowE (ot, t_exp context exp1)
   | TupE exps ->
     TupE (List.map (t_exp context) exps)
   | OptE exp1 ->
@@ -241,6 +243,8 @@ and c_exp' context exp k =
     binary context k (fun v1 v2 -> e (BinE (ot, v1, op, v2))) exp1 exp2
   | RelE (ot, exp1, op, exp2) ->
     binary context k (fun v1 v2 -> e (RelE (ot, v1, op, v2))) exp1 exp2
+  | ShowE (ot, exp1) ->
+    unary context k (fun v1 -> e (ShowE (ot, v1))) exp1
   | TupE exps ->
     nary context k (fun vs -> e (TupE vs)) exps
   | OptE exp1 ->

src/check_ir.ml

@@ -299,14 +299,20 @@ let rec check_exp env (exp:Ir.exp) : unit =
     check (Operator.has_unop ot op) "unary operator is not defined for operand type";
     check_exp env exp1;
     typ exp1 <: ot;
-    ot <: t;
+    ot <: t
   | BinE (ot, exp1, op, exp2) ->
     check (Operator.has_binop ot op) "binary operator is not defined for operand type";
     check_exp env exp1;
     check_exp env exp2;
     typ exp1 <: ot;
     typ exp2 <: ot;
     ot <: t;
+  | ShowE (ot, exp1) ->
+    check env.flavor.has_show "show expression in non-show flavor";
+    check (Show.can_show ot) "show is not defined for operand type";
+    check_exp env exp1;
+    typ exp1 <: ot;
+    T.Prim T.Text <: t
   | RelE (ot, exp1, op, exp2) ->
     check (Operator.has_relop ot op) "relational operator is not defined for operand type";
     check_exp env exp1;

src/construct.ml

@@ -199,6 +199,25 @@ let switch_optE exp1 exp2 pat exp3 typ1  =
            }
   }
 
+let switch_variantE exp1 cases typ1 =
+  { it =
+      SwitchE (exp1,
+        List.map (fun (l,p,e) ->
+          { it = {pat = {it = VariantP (l, p);
+                         at = no_region;
+                         note = typ exp1};
+                  exp = e};
+            at = no_region;
+            note = ()
+          })
+          cases
+      );
+    at = no_region;
+    note = { S.note_typ = typ1;
+             S.note_eff = List.fold_left max_eff (eff exp1) (List.map (fun (l,p,e) -> eff e) cases)
+           }
+  }
+
 let tupE exps =
   let effs = List.map eff exps in
   let eff = List.fold_left max_eff Type.Triv effs in

src/construct.mli

@@ -57,6 +57,7 @@ val callE : exp -> typ list -> exp -> exp
 val ifE : exp -> exp -> exp -> typ -> exp
 val dotE : exp -> name -> typ -> exp
 val switch_optE : exp -> exp -> pat -> exp -> typ -> exp
+val switch_variantE : exp -> (id * pat * exp) list -> typ -> exp
 val tupE : exp list -> exp
 val breakE: id -> exp -> exp
 val retE: exp -> exp

src/definedness.ml

@@ -92,6 +92,7 @@ let rec exp msgs e : f = match e.it with
   | UnE (_, uo, e)      -> exp msgs e
   | BinE (_, e1, bo, e2)-> exps msgs [e1; e2]
   | RelE (_, e1, ro, e2)-> exps msgs [e1; e2]
+  | ShowE (_, e)        -> exp msgs e
   | TupE es             -> exps msgs es
   | ProjE (e, i)        -> exp msgs e
   | ObjE (s, efs)       ->

src/desugar.ml

@@ -38,6 +38,8 @@ and exp' at note = function
     I.BinE (!ot, exp e1, o, exp e2)
   | S.RelE (ot, e1, o, e2) ->
     I.RelE (!ot, exp e1, o, exp e2)
+  | S.ShowE (ot, e) ->
+    I.ShowE (!ot, exp e)
   | S.TupE es -> I.TupE (exps es)
   | S.ProjE (e, i) -> I.ProjE (exp e, i)
   | S.OptE e -> I.OptE (exp e)
@@ -283,6 +285,7 @@ and prog (p : Syntax.prog) : Ir.prog =
   end
   , { I.has_await = true
     ; I.has_async_typ = true
+    ; I.has_show = true
     ; I.serialized = false
     }
 

src/effect.ml

@@ -31,6 +31,7 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff =
   | FuncE _ ->
     T.Triv
   | UnE (_, _, exp1)
+  | ShowE (_, exp1)
   | ProjE (exp1, _)
   | OptE exp1
   | VariantE (_, exp1)
@@ -123,6 +124,7 @@ module Ir =
       | LitE _ ->
         T.Triv
       | UnE (_, _, exp1)
+      | ShowE (_, exp1)
       | ProjE (exp1, _)
       | OptE exp1
       | VariantE (_, exp1)

src/freevars.ml

@@ -65,6 +65,7 @@ let rec exp e : f = match e.it with
   | UnE (_, uo, e)      -> exp e
   | BinE (_, e1, bo, e2) -> exps [e1; e2]
   | RelE (_, e1, ro, e2) -> exps [e1; e2]
+  | ShowE (_, e)        -> exp e
   | TupE es             -> exps es
   | ProjE (e, i)        -> exp e
   | DotE (e, i)         -> exp e

src/interpret.ml

@@ -252,6 +252,11 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
           trap exp.at "arithmetic overflow")
       )
     )
+  | ShowE (ot, exp1) ->
+    interpret_exp env exp1 (fun v ->
+      if Show.can_show !ot
+      then k (Value.Text (Show.show_val !ot v))
+      else raise (Invalid_argument "debug_show"))
   | RelE (ot, exp1, op, exp2) ->
     interpret_exp env exp1 (fun v1 ->
       interpret_exp env exp2 (fun v2 ->

src/interpret_ir.ml

@@ -278,6 +278,11 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
     k (interpret_lit env lit)
   | UnE (ot, op, exp1) ->
     interpret_exp env exp1 (fun v1 -> k (Operator.unop ot op v1))
+  | ShowE (ot, exp1) ->
+    interpret_exp env exp1 (fun v ->
+      if Show.can_show ot
+      then k (Value.Text (Show.show_val ot v))
+      else raise (Invalid_argument "debug_show"))
   | BinE (ot, exp1, op, exp2) ->
     interpret_exp env exp1 (fun v1 ->
       interpret_exp env exp2 (fun v2 ->

src/ir.ml

@@ -37,6 +37,7 @@ and exp' =
   | UnE of Type.typ * unop * exp               (* unary operator *)
   | BinE of Type.typ * exp * binop * exp       (* binary operator *)
   | RelE of Type.typ * exp * relop * exp       (* relational operator *)
+  | ShowE of Type.typ * exp                    (* debug show *)
   | TupE of exp list                           (* tuple *)
   | ProjE of exp * int                         (* tuple projection *)
   | OptE of exp                                (* option injection *)
@@ -97,6 +98,7 @@ should hold.
 type flavor = {
   has_async_typ : bool; (* AsyncT *)
   has_await : bool; (* AwaitE and AsyncE *)
+  has_show : bool; (* ShowE *)
   serialized : bool; (* Shared function arguments are serialized *)
 }
 

src/lexer.mll

@@ -208,6 +208,7 @@ rule token mode = parse
   | "private" { PRIVATE }
   | "return" { RETURN }
   | "shared" { SHARED }
+  | "debug_show" { DEBUG_SHOW }
   | "switch" { SWITCH }
   | "true" { BOOL true }
   | "type" { TYPE }

src/parser.mly

@@ -98,6 +98,7 @@ let share_expfield (ef : exp_field) =
 %token FUNC TYPE OBJECT ACTOR CLASS PRIVATE NEW SHARED
 %token SEMICOLON SEMICOLON_EOL COMMA COLON SUB DOT QUEST
 %token AND OR NOT
+%token DEBUG_SHOW
 %token ASSERT
 %token ADDOP SUBOP MULOP DIVOP MODOP POWOP
 %token ANDOP OROP XOROP SHLOP SHROP ROTLOP ROTROP
@@ -382,6 +383,8 @@ exp_un :
     { NotE e @? at $sloc }
   | i=variant_tag e=exp_nullary
     { VariantE (i, e) @? at $sloc }
+  | DEBUG_SHOW e=exp_un
+    { ShowE (ref Type.Pre, e) @? at $sloc }
 
 exp_bin :
   | e=exp_un

src/pipeline.ml

@@ -141,6 +141,9 @@ let serialization =
 let tailcall_optimization =
   transform_if "Tailcall optimization" (fun _ -> Tailcall.transform)
 
+let show_translation =
+  transform_if "Translate show" Show.transform
+
 let check_with parse infer senv name : check_result =
   match parse name with
   | Error e -> Error [e]
@@ -175,6 +178,7 @@ let interpret_prog (senv,denv) name prog : (Value.value * Interpret.scope) optio
         let prog_ir = async_lowering (!Flags.await_lowering && !Flags.async_lowering) senv prog_ir name in
         let prog_ir = serialization (!Flags.await_lowering && !Flags.async_lowering) senv prog_ir name in
         let prog_ir = tailcall_optimization true senv prog_ir name in
+        let prog_ir = show_translation true senv prog_ir name in
         Interpret_ir.interpret_prog denv prog_ir
       else Interpret.interpret_prog denv prog in
     match vo with
@@ -301,6 +305,7 @@ let compile_with check mode name : compile_result =
     let prog_ir = async_lowering true initial_stat_env prog_ir name in
     let prog_ir = serialization true initial_stat_env prog_ir name in
     let prog_ir = tailcall_optimization true initial_stat_env prog_ir name in
+    let prog_ir = show_translation true initial_stat_env prog_ir name in
     phase "Compiling" name;
     let module_ = Compile.compile mode name prelude_ir [prog_ir] in
     Ok module_

src/prelude.ml

@@ -91,6 +91,98 @@ func clzWord64(w : Word64) : Word64 = (prim "clz64" : Word64 -> Word64) w;
 func ctzWord64(w : Word64) : Word64 = (prim "ctz64" : Word64 -> Word64) w;
 func btstWord64(w : Word64, amount : Word64) : Bool = (prim "btst64" : (Word64, Word64) -> Word64) (w, amount) != (0 : Word64);
 
+// Internal helper functions for the show translation
+
+// The @ in the name ensures that this connot be shadowed by user code, so
+// compiler passes can rely on them being in scope
+// The text_of functions do not need to be exposed; the user can just use
+// the show above.
+
+func @text_of_Nat(x : Nat) : Text {
+  var text = "";
+  var n = x;
+  let base = 10;
+
+  while (n > 0) {
+    let rem = n % base;
+    text := (switch (rem) {
+      case (0) { "0" };
+      case (1) { "1" };
+      case (2) { "2" };
+      case (3) { "3" };
+      case (4) { "4" };
+      case (5) { "5" };
+      case (6) { "6" };
+      case (7) { "7" };
+      case (8) { "8" };
+      case (9) { "9" };
+      case (_) { assert false; "" };
+    }) # text;
+    n := n / base;
+  };
+  return text;
+};
+
+func @text_of_Int(x : Int) : Text {
+  if (x == 0) {
+    return "0";
+  };
+  if (x < 0) {
+    "-" # @text_of_Nat(abs x)
+  } else {
+    @text_of_Nat(abs x)
+  }
+};
+
+func @text_of_Bool(b : Bool) : Text {
+  if (b) "true" else "false"
+};
+
+func @text_of_Text(t : Text) : Text {
+  // TODO: Escape properly
+  "\"" # t # "\"";
+};
+
+func @text_of_option<T>(f : T -> Text, x : ?T) : Text {
+  switch (x) {
+    case (?y) {"?(" # f y # ")"};
+    case null {"null"};
+  }
+};
+
+func @text_of_variant<T>(l : Text, f : T -> Text, x : T) : Text {
+  "(#" # l # " " # f x # ")"
+};
+
+func @text_of_array<T>(f : T -> Text, xs : [T]) : Text {
+  var text = "";
+  for (x in xs.vals()) {
+    if (text == "") {
+      text := text # "[";
+    } else {
+      text := text # ", ";
+    };
+    text := text # f x;
+  };
+  text := text # "]";
+  return text;
+};
+
+func @text_of_array_mut<T>(f : T -> Text, xs : [var T]) : Text {
+  var text = "";
+  for (x in xs.vals()) {
+    if (text == "") {
+      text := text # "[var ";
+    } else {
+      text := text # ", ";
+    };
+    text := text # f x;
+  };
+  text := text # "]";
+  return text;
+};
+
+// Array utilities
 
 // This would be nicer as a objects, but lets do them as functions
 // until the compiler has a concept of “static objects”

src/rename.ml

@@ -36,6 +36,7 @@ and exp' rho e  = match e with
   | UnE (ot, uo, e)      -> UnE (ot, uo, exp rho e)
   | BinE (ot, e1, bo, e2)-> BinE (ot, exp rho e1, bo, exp rho e2)
   | RelE (ot, e1, ro, e2)-> RelE (ot, exp rho e1, ro, exp rho e2)
+  | ShowE (ot, e)       -> ShowE (ot, exp rho e)
   | TupE es             -> TupE (List.map (exp rho) es)
   | ProjE (e, i)        -> ProjE (exp rho e, i)
   | ActorE (i, ds, fs, t)-> let i',rho' = id_bind rho i in

src/serialization.ml

@@ -162,6 +162,8 @@ module Transform() = struct
       BinE (t_typ ot, t_exp exp1, op, t_exp exp2)
     | RelE (ot, exp1, op, exp2) ->
       RelE (t_typ ot, t_exp exp1, op, t_exp exp2)
+    | ShowE (ot, exp1) ->
+      ShowE (t_typ ot, t_exp exp1)
     | TupE exps ->
       TupE (List.map t_exp exps)
     | OptE exp1 ->