Eval: tracing support

.gitignore

@@ -1,5 +1,4 @@
 asli
-asli.docdir
 *.byte
 *.native
 .*.swp
@@ -13,6 +12,7 @@ asl_parser_pp.ml
 _build
 asl_unquotiented.*
 asl_quotiented.*
+test.native
 *.aux
 *.dvi
 *.log

asli.ml

@@ -108,11 +108,20 @@ let help_msg = [
     {|:project <file>                Execute ASLi commands in <file>|};
     {|:q :quit                       Exit the interpreter|};
     {|:set impdef <string> = <expr>  Define implementation defined behavior|};
+    {|:set +<flag>                   Set flag|};
+    {|:set -<flag>                   Clear flag|};
     {|:? :help                       Show this help message|};
     {|<expr>                         Execute ASL expression|};
     {|<stmt> ;                       Execute ASL statement|}
 ]
 
+let flags = [
+    ("trace:write", Eval.trace_write);
+    ("trace:fun",   Eval.trace_funcall);
+    ("trace:prim",  Eval.trace_primop);
+    ("trace:instr", Eval.trace_instruction)
+]
+
 let mkLoc (fname: string) (input: string): AST.l =
     let len = String.length input in
     let start : Lexing.position = { pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } in
@@ -125,7 +134,9 @@ let rec process_command (tcenv: TC.Env.t) (env: Eval.Env.t) (fname: string) (inp
     | [""] ->
         ()
     | [":help"] | [":?"] ->
-        List.iter print_endline help_msg
+        List.iter print_endline help_msg;
+        print_endline "\nFlags:";
+        List.iter (fun (nm, v) -> Printf.printf "  %s%s\n" (if !v then "+" else "-") nm) flags
     | (":set" :: "impdef" :: rest) ->
         let cmd    = String.concat " " rest in
         let loc    = mkLoc fname cmd in
@@ -159,6 +170,16 @@ let rec process_command (tcenv: TC.Env.t) (env: Eval.Env.t) (fname: string) (inp
             Printf.printf "  Error %s\n" (Printexc.to_string exc);
             Printexc.print_backtrace stdout
         )
+    | [":set"; flag] when Utils.startswith flag "+" ->
+        (match List.assoc_opt (Utils.stringDrop 1 flag) flags with
+        | None -> Printf.printf "Unknown flag %s\n" flag;
+        | Some f -> f := true
+        )
+    | [":set"; flag] when Utils.startswith flag "-" ->
+        (match List.assoc_opt (Utils.stringDrop 1 flag) flags with
+        | None -> Printf.printf "Unknown flag %s\n" flag;
+        | Some f -> f := false
+        )
     | [":project"; prj] ->
         let inchan = open_in prj in
         (try

eval.ml

@@ -21,8 +21,17 @@ open Value
  * Flags to control behaviour (mostly for debugging)
  ****************************************************************)
 
+(** Debugging output on every variable write *)
+let trace_write = ref false
+
 (** Debugging output on every function call *)
-let trace_funcall = false
+let trace_funcall = ref false
+
+(** Debugging output on every primitive function or function call *)
+let trace_primop = ref false
+
+(** Debugging output on every instruction execution *)
+let trace_instruction = ref false
 
 
 (** It is an error to have multiple function definitions with conflicting types.
@@ -174,6 +183,7 @@ end = struct
         k child
 
     let addLocalVar (loc: l) (env: t) (x: ident) (v: value): unit =
+        if !trace_write then Printf.printf "TRACE: fresh %s = %s\n" (pprint_ident x) (pp_value v);
         (match env.locals with
         | (bs :: _) -> set_scope x v bs
         | []        -> raise (EvalError (loc, "addLocalVar"))
@@ -236,6 +246,7 @@ end = struct
         )
 
     let setVar (loc: l) (env: t) (x: ident) (v: value): unit =
+        if !trace_write then Printf.printf "TRACE: write %s = %s\n" (pprint_ident x) (pp_value v);
         (match findScope env x with
         | Some bs -> set_scope x v bs
         | None    -> raise (EvalError (loc, "setVar " ^ pprint_ident x))
@@ -730,17 +741,23 @@ and eval_stmt (env: Env.t) (x: AST.stmt): unit =
 
 (** Evaluate call to function or procedure *)
 and eval_call (loc: l) (env: Env.t) (f: ident) (tvs: value list) (vs: value list): unit =
-    if trace_funcall then begin
-        Printf.printf "eval_call: %s " (pprint_ident f);
-        List.iter (fun v -> Printf.printf " [%s]" (pp_value v)) tvs;
-        List.iter (fun v -> Printf.printf " %s" (pp_value v)) vs;
-        Printf.printf "\n"
-    end;
     (match eval_prim (name_of_FIdent f) tvs vs with
     | Some r ->
+        if !trace_primop then begin
+            Printf.printf "TRACE primop: %s " (pprint_ident f);
+            List.iter (fun v -> Printf.printf " [%s]" (pp_value v)) tvs;
+            List.iter (fun v -> Printf.printf " %s" (pp_value v)) vs;
+            Printf.printf " --> %s\n" (pp_value r);
+        end;
         raise (Return (Some r))
     | None ->
         begin
+            if !trace_funcall then begin
+                Printf.printf "TRACE funcall: %s " (pprint_ident f);
+                List.iter (fun v -> Printf.printf " [%s]" (pp_value v)) tvs;
+                List.iter (fun v -> Printf.printf " %s" (pp_value v)) vs;
+                Printf.printf "\n"
+            end;
             let (targs, args, loc, b) = Env.getFun loc env f in
             assert (List.length targs = List.length tvs);
             assert (List.length args  = List.length vs);
@@ -781,6 +798,7 @@ let eval_encoding (env: Env.t) (x: encoding) (op: value): bool =
     | Opcode_Mask m -> eval_inmask loc op (from_maskLit m)
     ) in
     if ok then begin
+        if !trace_instruction then Printf.printf "TRACE: instruction %s\n" (pprint_ident nm);
         List.iter (function (IField_Field (f, lo, wd)) ->
             Env.addLocalVar loc env f (extract_bits' loc op lo wd)
         ) fields;

utils.ml

@@ -137,6 +137,17 @@ let rec first_option (f: 'a -> 'b option) (xs: 'a list): 'b option =
  * String related
  ****************************************************************)
 
+(** Test whether 'x' starts with (is prefixed by) 'y' *)
+let startswith (x: string) (y: string): bool =
+    let lx = String.length x in
+    let ly = String.length y in
+    if lx < ly then begin
+        false
+    end else begin
+        let head = String.sub x 0 ly in
+        String.equal head y
+    end
+
 (** Test whether 'x' ends with (is suffixed by) 'y' *)
 let endswith (x: string) (y: string): bool =
     let lx = String.length x in
@@ -148,6 +159,14 @@ let endswith (x: string) (y: string): bool =
         String.equal tail y
     end
 
+(** Drop first n characters from string *)
+let stringDrop (n: int) (s: string): string =
+    let l = String.length s in
+    if n > l then begin
+        ""
+    end else begin
+        String.sub s n (l-n)
+    end
 
 (****************************************************************
  * End