summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorSon Ho2022-01-28 21:06:42 +0100
committerSon Ho2022-01-28 21:06:42 +0100
commitdae758e940e3bf023c25d86f7d05b8cea80c1ed5 (patch)
tree35aaaef6db2646672fde974e24b251389ac00bc5 /src
parent141709cff9564c45658ca98fd4523e4bd9399a33 (diff)
Make minor modifications
Diffstat (limited to 'src')
-rw-r--r--src/PureMicroPasses.ml32
-rw-r--r--src/PureUtils.ml12
2 files changed, 35 insertions, 9 deletions
diff --git a/src/PureMicroPasses.ml b/src/PureMicroPasses.ml
index 2cf27a7f..23ae22af 100644
--- a/src/PureMicroPasses.ml
+++ b/src/PureMicroPasses.ml
@@ -485,7 +485,7 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) (call0 : call)
(** Filter the unused assignments (removes the unused variables, filters
the function calls) *)
-let filter_unused_assignments (filter_monadic_calls : bool) (ctx : trans_ctx)
+let filter_unused (filter_monadic_calls : bool) (ctx : trans_ctx)
(def : fun_def) : fun_def =
(* We first need a transformation on *left-values*, which filters the unused
* variables and tells us whether the value contains any variable which has
@@ -667,7 +667,25 @@ let unit_vars_to_unit (def : fun_def) : fun_def =
(** Unfold the monadic let-bindings to explicit matches. *)
let unfold_monadic_let_bindings (ctx : trans_ctx) (def : fun_def) : fun_def =
- raise Unimplemented
+ def
+(* (* It is a very simple map *)
+ let obj =
+ object
+ inherit [_] map_expression as super
+
+ method! visit_Let env monadic lv e re =
+ if not monadic then super#visit_Let env monadic lv e re
+ else
+ let fail_pat = mk_result_fail_lvalue lv.ty in
+ let success_pat = mk_result_return_lvalue lv in
+ let e = Switch
+
+ end
+ in
+ (* Update the body *)
+ let body = obj#visit_expression () def.body in
+ (* Return *)
+ { def with body}*)
(** Apply all the micro-passes to a function.
@@ -718,13 +736,9 @@ let apply_passes_to_def (config : config) (ctx : trans_ctx) (def : fun_def) :
(lazy
("inline_useless_var_assignments:\n\n" ^ fun_def_to_string ctx def ^ "\n"));
- (* Filter the unused assignments (removes the unused variables, filters
- * the function calls) *)
- let def =
- filter_unused_assignments config.filter_unused_monadic_calls ctx def
- in
- log#ldebug
- (lazy ("filter_unused_assignments:\n\n" ^ fun_def_to_string ctx def ^ "\n"));
+ (* Filter the unused variables, assignments, function calls, etc. *)
+ let def = filter_unused config.filter_unused_monadic_calls ctx def in
+ log#ldebug (lazy ("filter_unused:\n\n" ^ fun_def_to_string ctx def ^ "\n"));
(* Unfold the monadic let-bindings *)
let def =
diff --git a/src/PureUtils.ml b/src/PureUtils.ml
index 140f4082..9596cd9b 100644
--- a/src/PureUtils.ml
+++ b/src/PureUtils.ml
@@ -58,6 +58,18 @@ let mk_result_return_rvalue (v : typed_rvalue) : typed_rvalue =
in
{ value; ty }
+let mk_result_fail_lvalue (ty : ty) : typed_lvalue =
+ let ty = Adt (Assumed Result, [ ty ]) in
+ let value = LvAdt { variant_id = Some result_fail_id; field_values = [] } in
+ { value; ty }
+
+let mk_result_return_lvalue (v : typed_lvalue) : typed_lvalue =
+ let ty = Adt (Assumed Result, [ v.ty ]) in
+ let value =
+ LvAdt { variant_id = Some result_return_id; field_values = [ v ] }
+ in
+ { value; ty }
+
let mk_result_ty (ty : ty) : ty = Adt (Assumed Result, [ ty ])
(** Type substitution *)