diff options
| -rw-r--r-- | src/PureMicroPasses.ml | 32 | ||||
| -rw-r--r-- | src/PureUtils.ml | 12 |
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 *) |