Beginnings of post-resolve simplify pass.

src/Makefile

@@ -233,8 +233,8 @@ BE_MLS := $(addprefix boot/be/, x86.ml ra.ml pe.ml elf.ml \
           macho.ml)
 IL_MLS := $(addprefix boot/be/, asm.ml il.ml abi.ml)
 ME_MLS := $(addprefix boot/me/, walk.ml semant.ml resolve.ml alias.ml \
-            type.ml dead.ml effect.ml typestate.ml loop.ml layout.ml  \
-            transutil.ml trans.ml dwarf.ml)
+            simplify.ml type.ml dead.ml effect.ml typestate.ml loop.ml \
+            layout.ml transutil.ml trans.ml dwarf.ml)
 FE_MLS := $(addprefix boot/fe/, ast.ml token.ml lexer.ml parser.ml pexp.ml \
             item.ml cexp.ml fuzz.ml)
 DRIVER_TOP_MLS := $(addprefix boot/driver/, lib.ml $(VARIANT)/glue.ml main.ml)

src/boot/driver/llvm/glue.ml

@@ -15,6 +15,7 @@ let alt_pipeline sess sem_cx crate =
   Array.iter process
     [|
       Resolve.process_crate;
+      Simplify.process_crate;
       Type.process_crate;
       Typestate.process_crate;
       Effect.process_crate;

src/boot/driver/main.ml

@@ -34,6 +34,7 @@ let (sess:Session.sess) =
     Session.sess_log_ast = false;
     Session.sess_log_resolve = false;
     Session.sess_log_type = false;
+    Session.sess_log_simplify = false;
     Session.sess_log_effect = false;
     Session.sess_log_typestate = false;
     Session.sess_log_loop = false;
@@ -162,6 +163,8 @@ let argspecs =
        "-lresolve"  "log resolution");
     (flag (fun _ -> sess.Session.sess_log_type <- true)
        "-ltype"     "log type checking");
+    (flag (fun _ -> sess.Session.sess_log_simplify <- true)
+       "-lsimplify" "log simplification");
     (flag (fun _ -> sess.Session.sess_log_effect <- true)
        "-leffect"   "log effect checking");
     (flag (fun _ -> sess.Session.sess_log_typestate <- true)
@@ -352,6 +355,7 @@ let main_pipeline _ =
          proc sem_cx crate;
          exit_if_failed ())
       [| Resolve.process_crate;
+         Simplify.process_crate;
          Type.process_crate;
          Typestate.process_crate;
          Effect.process_crate;

src/boot/driver/session.ml

@@ -20,6 +20,7 @@ type sess =
   mutable sess_log_ast: bool;
   mutable sess_log_resolve: bool;
   mutable sess_log_type: bool;
+  mutable sess_log_simplify: bool;
   mutable sess_log_effect: bool;
   mutable sess_log_typestate: bool;
   mutable sess_log_dead: bool;

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:
+ *)
+