Json ast dumping in phase-stats.mc

src/main/compile.mc

@@ -40,7 +40,8 @@ lang MCoreCompile =
   MExprConstantFold +
   OCamlTryWithWrap + MCoreCompileLang + PhaseStats +
   SpecializeCompile +
-  PprintTyAnnot + HtmlAnnotator
+  PprintTyAnnot + HtmlAnnotator +
+  MExprToJson
 end
 
 lang TyAnnotFull = MExprPrettyPrint + TyAnnot + HtmlAnnotator + MetaVarTypePrettyPrint
@@ -62,7 +63,7 @@ let insertTunedOrDefaults = lam options : Options. lam ast. lam file.
 
 let compileWithUtests = lam options : Options. lam sourcePath. lam ast.
   use MCoreCompile in
-    let log = mkPhaseLogState options.debugPhases in
+    let log = mkPhaseLogState options.debugDumpPhases options.debugPhases in
 
     -- If option --debug-profile, insert instrumented profiling expressions
     -- in AST
@@ -146,7 +147,7 @@ let compile = lam files. lam options : Options. lam args.
     iter (compileMLangToOcaml options compileWithUtests) files
   else
     let compileFile = lam file.
-      let log = mkPhaseLogState options.debugPhases in
+      let log = mkPhaseLogState options.debugDumpPhases options.debugPhases in
       let ast = parseParseMCoreFile {
         keepUtests = options.runTests,
         pruneExternalUtests = not options.disablePruneExternalUtests,

src/main/options-config.mc

@@ -39,6 +39,10 @@ let optionsConfig : ParseConfig Options = [
     "Show debug and profiling information about each pass",
     lam p: ArgPart Options.
       let o: Options = p.options in {o with debugPhases = true}),
+  ([("--debug-phase", " ", "<phase>")],
+    "Print a json representation of the AST after the given pass. Can be given multiple times.",
+    lam p: ArgPart Options.
+      let o: Options = p.options in {o with debugDumpPhases = setInsert (argToString p) o.debugDumpPhases}),
   ([("--exit-before", "", "")],
     "Exit before evaluation or compilation",
     lam p: ArgPart Options.

src/main/options-type.mc

@@ -1,4 +1,5 @@
 include "tuning/tune-options.mc"
+include "set.mc"
 
 -- Options type
 type Options = {
@@ -11,6 +12,7 @@ type Options = {
   debugShallow : Bool,
   debugConstantFold : Bool,
   debugPhases : Bool,
+  debugDumpPhases : Set String,
   exitBefore : Bool,
   disablePruneExternalUtests : Bool,
   disablePruneExternalUtestsWarning : Bool,

src/main/options.mc

@@ -14,6 +14,7 @@ let optionsDefault : Options = {
   debugShallow = false,
   debugConstantFold = false,
   debugPhases = false,
+  debugDumpPhases = setEmpty cmpString,
   exitBefore = false,
   disablePruneExternalUtests = false,
   disablePruneExternalUtestsWarning = false,

src/stdlib/mexpr/json-debug.mc

@@ -10,10 +10,18 @@ include "mlang/ast.mc"
 
 lang AstToJson = Ast + DeclAst
   sem exprToJson : Expr -> JsonValue
+  sem exprToJson =
+  | tm -> error (join ["Missing case in exprToJson ", info2str (infoTm tm)])
   sem typeToJson : Type -> JsonValue
+  sem typeToJson =
+  | ty -> error (join ["Missing case in typeToJson ", info2str (infoTy ty)])
   sem kindToJson : Kind -> JsonValue
   sem patToJson : Pat -> JsonValue
+  sem patToJson =
+  | pat -> error (join ["Missing case in patToJson ", info2str (infoPat pat)])
   sem declToJson : Decl -> JsonValue
+  sem declToJson =
+  | decl -> error (join ["Missing case in declToJson ", info2str (infoDecl decl)])
 
   sem optToNull : Option JsonValue -> JsonValue
   sem optToNull =

src/stdlib/mexpr/phase-stats.mc

@@ -1,27 +1,42 @@
 include "common.mc"
 include "ast.mc"
+include "json-debug.mc"
 
-lang PhaseStats = Ast
+lang PhaseStats = Ast + AstToJson
   type StatState =
     { lastPhaseEnd : Ref Float
     , log : Bool
+    , jsonDumpPhases : Set String
     }
 
   sem endPhaseStats : StatState -> String -> Expr -> ()
   sem endPhaseStats state phaseLabel = | e ->
-    if state.log then
-      let before = deref state.lastPhaseEnd in
-      let now = wallTimeMs () in
+    let before = deref state.lastPhaseEnd in
+    let now = wallTimeMs () in
+
+    (if state.log then
       printLn phaseLabel;
       printLn (join ["  Phase duration: ", float2string (subf now before), "ms"]);
       let preTraverse = wallTimeMs () in
       let size = countExprNodes 0 e in
       let postTraverse = wallTimeMs () in
-      printLn (join ["  Ast size: ", int2string size, " (Traversal takes ~", float2string (subf postTraverse preTraverse), "ms)"]);
-      let newNow = wallTimeMs () in
-      modref state.lastPhaseEnd newNow
-    else ()
+      printLn (join ["  Ast size: ", int2string size, " (Traversal takes ~", float2string (subf postTraverse preTraverse), "ms)"])
+     else ());
+
+    (if setMem phaseLabel state.jsonDumpPhases then
+      printJsonLn (JsonString (concat "Computing AST after " phaseLabel));
+      let e = exprToJson e in
+      printJsonLn (JsonString (concat "Printing AST after " phaseLabel));
+      printJsonLn e
+     else ());
 
-  sem mkPhaseLogState : Bool -> StatState
-  sem mkPhaseLogState = | log -> { lastPhaseEnd = ref (wallTimeMs ()), log = log }
+    let newNow = wallTimeMs () in
+    modref state.lastPhaseEnd newNow
+
+  sem mkPhaseLogState : Set String -> Bool -> StatState
+  sem mkPhaseLogState jsonDumpPhases = | log ->
+    { lastPhaseEnd = ref (wallTimeMs ())
+    , jsonDumpPhases = jsonDumpPhases
+    , log = log
+    }
 end

src/stdlib/mlang/main.mc

@@ -1,5 +1,5 @@
 -- The main file of the MLang pipline.
--- The semantic function `compileMLangToOcaml`, takes a filepath as input. 
+-- The semantic function `compileMLangToOcaml`, takes a filepath as input.
 -- It then puts the program at this file through the MLang pipeline and then
 -- compiles it to OCaml.
 
@@ -25,54 +25,54 @@ include "mexpr/ast-builder.mc"
 include "mexpr/phase-stats.mc"
 include "mexpr/pprint.mc"
 
-lang MLangPipeline = MLangCompiler + BootParserMLang + 
+lang MLangPipeline = MLangCompiler + BootParserMLang +
                      MLangSym + MLangCompositionCheck +
-                     MExprPrettyPrint + MExprEval + MExprEq + 
+                     MExprPrettyPrint + MExprEval + MExprEq +
                      MLangConstTransformer + MLangIncludeHandler +
                      PhaseStats + LanguageComposer + PostProcess
 
   sem myEval : Expr -> Expr
   sem myEval =| e ->
-    eval (evalCtxEmpty ()) e 
+    eval (evalCtxEmpty ()) e
 
   -- TODO: re-add 'eval' through mlang-pipelineO
 
   -- TODO: add node count for MLang programs to phase-stats
   sem compileMLangToOcaml options runner =| filepath ->
-    let log = mkPhaseLogState options.debugPhases in
+    let log = mkPhaseLogState options.debugDumpPhases options.debugPhases in
 
-    let p = parseAndHandleIncludes filepath in 
+    let p = parseAndHandleIncludes filepath in
     endPhaseStats log "parsing-include-handling" uunit_;
 
     let p = constTransformProgram builtin p in
     endPhaseStats log "const-transformation" uunit_;
 
-    let p = composeProgram p in 
+    let p = composeProgram p in
     endPhaseStats log "language-inclusion-generation" uunit_;
 
-    match symbolizeMLang symEnvDefault p with (_, p) in 
+    match symbolizeMLang symEnvDefault p with (_, p) in
     endPhaseStats log "symbolization" uunit_;
 
-    match result.consume (checkComposition p) with (_, res) in 
+    match result.consume (checkComposition p) with (_, res) in
     endPhaseStats log "composition-check" uunit_;
 
-    switch res 
-      case Left errs then 
+    switch res
+      case Left errs then
         iter raiseError errs ;
         never
       case Right env then
-        let ctx = _emptyCompilationContext env in 
-        let res = result.consume (compile ctx p) in 
-        match res with (_, rhs) in 
+        let ctx = _emptyCompilationContext env in
+        let res = result.consume (compile ctx p) in
+        match res with (_, rhs) in
         match rhs with Right expr in
         endPhaseStats log "mlang-mexpr-lower" expr;
 
-        let expr = postprocess env.semSymMap expr in 
+        let expr = postprocess env.semSymMap expr in
         endPhaseStats log "postprocess" expr;
 
         -- printLn (expr2str expr);
 
         runner options filepath expr;
         ()
     end
-end
+end