Optimize let-bindings.inplace_let

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/inplace_let@10475 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

2 files changed, 48 insertions, 0 deletions

diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 21006cc695..295cea6b14 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -2567,6 +2567,53 @@ let for_trywith param pat_act_list =
 let for_let loc param pat body =
   compile_matching loc None (partial_function loc) param [pat, body] Partial
 
+let rec transform_return f = function
+  | Llet (k, id, l1, l2) -> Llet (k, id, l1, transform_return f l2)
+  | Lletrec (l1, l2) -> Lletrec (l1, transform_return f l2)
+  | Lifthenelse (lcond, lthen, lelse) -> Lifthenelse (lcond, transform_return f lthen, transform_return f lelse)
+  | Lsequence (l1, l2) -> Lsequence (l1, transform_return f l2)
+  | l -> f l
+
+let rec seq = function
+  | [] -> Lconst (Const_pointer 0)
+  | [l] -> l
+  | l1 :: rest -> Lsequence (l1, seq rest)
+
+let copy_ids ids =
+  seq (List.map (fun (id, id') -> Lassign (id, Lvar id')) ids)
+
+let rec assign_pat opt loc pat lam =
+  match pat.pat_desc, lam with
+  | Tpat_tuple patl, Lprim(Pmakeblock _, lams) ->
+      opt := true;
+      seq (List.rev (List.map2 (assign_pat opt loc) patl lams))
+  | Tpat_tuple patl, Lconst(Const_block (_, scl)) ->
+      opt := true;
+      seq (List.map2 (fun p sc -> assign_pat opt loc p (Lconst sc)) patl scl)
+  | Tpat_var id, lam ->
+      Lassign(id, lam)
+  | _ ->
+      let ids = pat_bound_idents pat in
+      let ids = List.map (fun id -> id, Ident.rename id) ids in
+      let pat' = alpha_pat ids pat in
+      for_let loc lam pat' (copy_ids ids)
+
+let for_let loc param pat body =
+  match pat.pat_desc with
+  | Tpat_any | Tpat_var _ -> for_let loc param pat body
+  | _ ->
+      let opt = ref false in
+      let ids = pat_bound_idents pat in
+      let bind = transform_return (assign_pat opt loc pat) param in
+      let cont = Lsequence (bind, body) in
+      if !opt then
+        List.fold_left
+          (fun k id -> Llet (Variable, id, Lconst (Const_pointer 0), k))
+          cont
+          ids
+      else
+        for_let loc param pat body
+
 (* Handling of tupled functions and matchings *)
 
 (* Easy case since variables are available *)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index eb64937cfe..eed5d69931 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -163,6 +163,7 @@ val map_pattern_desc : (pattern -> pattern) -> pattern_desc -> pattern_desc
 
 val let_bound_idents: (pattern * expression) list -> Ident.t list
 val rev_let_bound_idents: (pattern * expression) list -> Ident.t list
+val pat_bound_idents: pattern -> Ident.t list
 
 (* Alpha conversion of patterns *)
 val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern