summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSon Ho2023-12-21 23:02:51 +0100
committerSon Ho2023-12-21 23:02:51 +0100
commit6dc2b0f0906adc5d6f8f2f48404cf21d3595c957 (patch)
tree0257a6d60a608828dac9700ed50891e3b154154f
parenteae740d644f5ccd1ad2a7e853a9cdf303c8df61e (diff)
Improve the pure micro passes
Diffstat (limited to '')
-rw-r--r--compiler/PureMicroPasses.ml36
-rw-r--r--compiler/PureUtils.ml13
2 files changed, 46 insertions, 3 deletions
diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml
index 156fba29..67495ab5 100644
--- a/compiler/PureMicroPasses.ml
+++ b/compiler/PureMicroPasses.ml
@@ -674,6 +674,16 @@ let intro_struct_updates (ctx : trans_ctx) (def : fun_decl) : fun_decl =
let x := y
...
]}
+
+ Simplify tuples:
+ {[
+ let (y0, y1) := (x0, x1) in
+ ...
+ ~~>
+ let y0 = x0 in
+ let y1 = x1 in
+ ...
+ ]}
*)
let simplify_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl =
let obj =
@@ -705,10 +715,30 @@ let simplify_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl =
x ) ->
(* return/fail case *)
if variant_id = result_return_id then
- (* Return case *)
- super#visit_Let env false lv x next
- else if variant_id = result_fail_id then (* Fail case *) rv.e
+ (* Return case - note that the simplification we just perform
+ might have unlocked the tuple simplification below *)
+ self#visit_Let env false lv x next
+ else if variant_id = result_fail_id then
+ (* Fail case *)
+ self#visit_expression env rv.e
else raise (Failure "Unexpected")
+ | App _ ->
+ (* This might be the tuple case *)
+ if not monadic then
+ match
+ (opt_dest_struct_pattern lv, opt_dest_tuple_texpression rv)
+ with
+ | Some pats, Some vals ->
+ (* Tuple case *)
+ let pat_vals = List.combine pats vals in
+ let e =
+ List.fold_right
+ (fun (pat, v) next -> mk_let false pat v next)
+ pat_vals next
+ in
+ super#visit_expression env e.e
+ | _ -> super#visit_Let env monadic lv rv next
+ else super#visit_Let env monadic lv rv next
| _ -> super#visit_Let env monadic lv rv next
end
in
diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml
index 78d0b120..cc439e64 100644
--- a/compiler/PureUtils.ml
+++ b/compiler/PureUtils.ml
@@ -739,3 +739,16 @@ let rec destruct_lambdas (e : texpression) : typed_pattern list * texpression =
let pats, e = destruct_lambdas e in
(pat :: pats, e)
| _ -> ([], e)
+
+let opt_dest_tuple_texpression (e : texpression) : texpression list option =
+ let app, args = destruct_apps e in
+ match app.e with
+ | Qualif { id = AdtCons { adt_id = TTuple; variant_id = None }; generics = _ }
+ ->
+ Some args
+ | _ -> None
+
+let opt_dest_struct_pattern (pat : typed_pattern) : typed_pattern list option =
+ match pat.value with
+ | PatAdt { variant_id = None; field_values } -> Some field_values
+ | _ -> None