Beginnings of post-resolve simplify pass.

1 files changed, 110 insertions, 0 deletions

diff --git a/src/boot/me/simplify.ml b/src/boot/me/simplify.ml
new file mode 100644
index 00000000..ddc17e92
--- /dev/null
+++ b/src/boot/me/simplify.ml
@@ -0,0 +1,110 @@
+open Common;;
+open Semant;;
+
+let log cx =
+  Session.log
+    "simplify"
+    cx.Semant.ctxt_sess.Session.sess_log_simplify
+    cx.Semant.ctxt_sess.Session.sess_log_out
+
+let iflog cx thunk =
+  if cx.Semant.ctxt_sess.Session.sess_log_simplify
+  then thunk ()
+  else ()
+;;
+
+
+let plval_const_marking_visitor
+    (cx:Semant.ctxt)
+    (inner:Walk.visitor)
+    : Walk.visitor =
+  let visit_pexp_pre pexp =
+    begin
+      match pexp.node with
+          Ast.PEXP_lval pl ->
+            begin
+              let id = lval_base_id_to_defn_base_id cx pexp.id in
+              let is_const =
+                if defn_id_is_item cx id
+                then match (get_item cx id).Ast.decl_item with
+                    Ast.MOD_ITEM_const _ -> true
+                  | _ -> false
+                else false
+              in
+                iflog cx (fun _ -> log cx "plval %a refers to %s"
+                            Ast.sprintf_plval pl
+                            (if is_const then "const item" else "non-const"));
+                htab_put cx.ctxt_plval_const pexp.id is_const
+            end
+        | _ -> ()
+    end;
+    inner.Walk.visit_pexp_pre pexp
+  in
+
+  let visit_pexp_post p =
+    inner.Walk.visit_pexp_post p;
+    iflog cx (fun _ -> log cx "pexp %a is %s"
+                Ast.sprintf_pexp p
+                (if pexp_is_const cx p
+                 then "constant"
+                 else "non-constant"))
+  in
+
+    { inner with
+        Walk.visit_pexp_pre = visit_pexp_pre;
+        Walk.visit_pexp_post = visit_pexp_post;
+    }
+;;
+
+
+let pexp_simplifying_visitor
+    (_:Semant.ctxt)
+    (inner:Walk.visitor)
+    : Walk.visitor =
+
+  let walk_atom at =
+    match at with
+        Ast.ATOM_pexp _ ->
+          begin
+            (* FIXME: move desugaring code from frontend to here. *)
+            ()
+          end
+      | _ -> ()
+  in
+
+  let visit_stmt_pre s =
+    begin
+      match s.node with
+          Ast.STMT_copy (_, Ast.EXPR_atom a) -> walk_atom a
+        | _ -> ()
+    end;
+    inner.Walk.visit_stmt_pre s;
+  in
+    { inner with
+        Walk.visit_stmt_pre = visit_stmt_pre;
+    }
+;;
+
+
+let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit =
+  let path = Stack.create () in
+
+  let passes =
+    [|
+      (plval_const_marking_visitor cx Walk.empty_visitor);
+      (pexp_simplifying_visitor cx Walk.empty_visitor)
+    |]
+  in
+  let log_flag = cx.Semant.ctxt_sess.Session.sess_log_simplify in
+    Semant.run_passes cx "simplify" path passes log_flag log crate
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+