summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--asmcomp/cmmgen.ml233
-rw-r--r--binary-compat/compat/3.11.2/.gitignore0
-rw-r--r--binary-compat/compat/3.12.0/.gitignore0
-rw-r--r--camlp4/camlp4/.gitignore0
-rw-r--r--camlp4/etc/.gitignore0
-rw-r--r--camlp4/lib/.gitignore0
-rw-r--r--camlp4/meta/.gitignore0
-rw-r--r--camlp4/ocaml_src/.gitignore0
-rw-r--r--camlp4/ocaml_src/camlp4/.gitignore0
-rw-r--r--camlp4/ocaml_src/lib/.gitignore0
-rw-r--r--camlp4/ocaml_src/meta/.gitignore0
-rw-r--r--camlp4/ocaml_src/odyl/.gitignore0
-rw-r--r--camlp4/ocpp/.gitignore0
-rw-r--r--camlp4/odyl/.gitignore0
-rw-r--r--camlp4/top/.gitignore0
-rw-r--r--jocparsing/.gitignore0
-rw-r--r--maccaml/.gitignore0
-rw-r--r--otherlibs/join/.gitignore0
-rw-r--r--otherlibs/labltk/example/.gitignore0
-rw-r--r--otherlibs/num/test/.gitignore0
-rw-r--r--otherlibs/threads/Tests/.gitignore0
-rw-r--r--testasmcomp/.gitignore0
-rw-r--r--testsuite/tests/typing-gadts/.gitignore0
23 files changed, 225 insertions, 8 deletions
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index d29f8c67c5..7d24f49700 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -218,6 +218,8 @@ let test_bool = function
(* Float *)
+let unboxed_ids = ref IdentSet.empty
+
let box_float c = Cop(Calloc, [alloc_float_header; c])
let rec unbox_float = function
@@ -229,8 +231,34 @@ let rec unbox_float = function
| Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el)
| Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2)
| Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2)
+ | Cvar id as c ->
+ (* lzarg identifier introducing by Matching.inline_lazy_force_switch *)
+ if Ident.name id <> "lzarg" then
+ unboxed_ids := IdentSet.add id !unboxed_ids;
+ Cop(Cload Double_u, [c])
+ | Cconst_symbol lbl as c ->
+ begin try
+ let (_, _, cst) =
+ List.find (fun (l, _, _) -> l = lbl)
+ (Compilenv.structured_constants ())
+ in
+ match cst with
+ | Const_base(Const_float f) -> Cconst_float f
+ | _ -> assert false
+ with Not_found ->
+ (* This can happen with global float symbols in inlined functions. *)
+ Cop(Cload Double_u, [c])
+ end
| c -> Cop(Cload Double_u, [c])
+
+let unbox_if_float e =
+ let back = !unboxed_ids in
+ let r = unbox_float e in
+ unboxed_ids := back;
+ r
+
+
(* Complex *)
let box_complex c_re c_im =
@@ -912,9 +940,10 @@ let rec transl = function
| _ ->
bind "met" (lookup_tag obj (transl met)) (call_met obj args))
| Ulet(id, exp, body) ->
- begin match is_unboxed_number exp with
- No_unboxing ->
+(* begin match is_unboxed_number exp with
+ No_unboxing ->*)
Clet(id, transl exp, transl body)
+(*
| Boxed_float ->
transl_unbox_let box_float unbox_float transl_unbox_float
id exp body
@@ -922,6 +951,7 @@ let rec transl = function
transl_unbox_let (box_int bi) (unbox_int bi) (transl_unbox_int bi)
id exp body
end
+*)
| Uletrec(bindings, body) ->
transl_letrec bindings (transl body)
@@ -1376,7 +1406,7 @@ and transl_prim_3 p arg1 arg2 arg3 dbg =
bind "arr" (transl arg1) (fun arr ->
Cifthenelse(is_addr_array_ptr arr,
addr_array_set arr index newval,
- float_array_set arr index (unbox_float newval)))))
+ float_array_set arr index (unbox_if_float newval)))))
| Paddrarray ->
addr_array_set (transl arg1) (transl arg2) (transl arg3)
| Pintarray ->
@@ -1396,14 +1426,14 @@ and transl_prim_3 p arg1 arg2 arg3 dbg =
Cifthenelse(is_addr_array_hdr hdr,
addr_array_set arr idx newval,
float_array_set arr idx
- (unbox_float newval)))
+ (unbox_if_float newval)))
else
Cifthenelse(is_addr_array_hdr hdr,
Csequence(make_checkbound dbg [addr_array_length hdr; idx],
addr_array_set arr idx newval),
Csequence(make_checkbound dbg [float_array_length hdr; idx],
float_array_set arr idx
- (unbox_float newval)))))))
+ (unbox_if_float newval)))))))
| Paddrarray ->
bind "newval" (transl arg3) (fun newval ->
bind "index" (transl arg2) (fun idx ->
@@ -1588,14 +1618,201 @@ and transl_letrec bindings cont =
fill_blocks rem
in init_blocks bsz
+let id_used id e =
+ let rec aux = function
+ | Cvar i | Cassign (i, _) when i = id -> raise Exit
+ | Clet (_, e1, e2) | Csequence (e1, e2)
+ | Ccatch (_,_, e1, e2) | Ctrywith (e1, _, e2) ->
+ aux e1; aux e2
+ | Cassign (_, e) | Cloop e -> aux e
+ | Ctuple el | Cop (_, el) | Cexit (_, el) -> List.iter aux el
+ | Cifthenelse (e1, e2, e3) -> aux e1; aux e2; aux e3
+ | Cswitch (e, _, ea) -> aux e; Array.iter aux ea
+ | _ -> ()
+ in
+ try aux e; false
+ with Exit -> true
+
+let really_unbox id unboxed_id body =
+ Clet(unboxed_id, Cop(Cload Double_u, [Cvar id]), body)
+
+(* Push the unboxing binding down the tree *)
+(* TODO: avoid repeated calls to id_used on the same branch *)
+let rec do_unbox id unboxed_id = function
+ | Cop (op, el) as body ->
+ let rec loop = function
+ | [] -> assert false
+ | [e] -> [do_unbox id unboxed_id e]
+ | e1 :: el when id_used unboxed_id e1 ->
+ if List.exists (id_used unboxed_id) el then raise Exit;
+ do_unbox id unboxed_id e1 :: el
+ | e1 :: el -> e1 :: loop el
+ in
+ begin try Cop (op, loop el)
+ with Exit -> really_unbox id unboxed_id body
+ end
+ | Clet(i, e1, e2) as body ->
+ if id_used unboxed_id e1 then
+ if id_used unboxed_id e2 then really_unbox id unboxed_id body
+ else Clet(i, do_unbox id unboxed_id e1, e2)
+ else
+ Clet(i, e1, do_unbox id unboxed_id e2)
+ | Cvar i when i = unboxed_id ->
+ Cop(Cload Double_u, [Cvar id])
+ | body ->
+ really_unbox id unboxed_id body
+
+let transl_with_unboxing name params body =
+ let rec loop body =
+ if IdentSet.is_empty !unboxed_ids then body
+ else let ids = !unboxed_ids in
+ unboxed_ids := IdentSet.empty;
+ (* Traverse the body to find out, for each id:
+ - whether it is assigned;
+ - whether it is used directly in boxed form.
+ *)
+ let need_boxed = ref IdentSet.empty in
+ let assigned = ref IdentSet.empty in
+ let rec check = function
+ | Cop(Cload Double_u, [Cvar _]) ->
+ ()
+ | Cvar id ->
+ if IdentSet.mem id ids then
+ need_boxed := IdentSet.add id !need_boxed
+ | Cassign (id, exp) ->
+ if IdentSet.mem id ids then
+ assigned := IdentSet.add id !assigned;
+ check exp
+
+ | Cconst_int _
+ | Cconst_natint _
+ | Cconst_float _
+ | Cconst_symbol _
+ | Cconst_pointer _
+ | Cconst_natpointer _ -> ()
+ | Clet (_, e1, e2)
+ | Csequence (e1, e2)
+ | Ccatch (_, _, e1, e2)
+ | Ctrywith (e1, _, e2) -> check e1; check e2
+ | Ctuple el
+ | Cop (_, el)
+ | Cexit (_, el) -> List.iter check el
+ | Cifthenelse (e1, e2, e3) -> check e1; check e2; check e3
+ | Cswitch (e, _, ea) -> check e; Array.iter check ea
+ | Cloop e -> check e
+ in
+ check body;
+ let assigned = !assigned and need_boxed = !need_boxed in
+
+ Printf.printf "Float variables in function %s:\n%!" name;
+ IdentSet.iter
+ (fun id ->
+ Printf.printf "Ident: %s" (Ident.unique_name id);
+ if IdentSet.mem id assigned then Printf.printf " (assigned)";
+ if IdentSet.mem id need_boxed then Printf.printf " (need_boxed)";
+ Printf.printf "\n%!"
+ ) ids;
+
+ let unboxed_id_tbl = ref Ident.empty in
+ let create_unboxed_id id =
+ let unboxed_id = Ident.create (Ident.name id ^ "_unboxed") in
+ unboxed_id_tbl := Ident.add id unboxed_id !unboxed_id_tbl;
+ unboxed_id
+ in
+ let get_unboxed_id id =
+ try Ident.find_same id !unboxed_id_tbl
+ with Not_found ->
+ fatal_error (Printf.sprintf "Cannot find unboxed id for %s" (Ident.unique_name id))
+ in
+ let rec subst = function
+ | Cvar id when IdentSet.mem id ids && IdentSet.mem id assigned ->
+ let unboxed_id = get_unboxed_id id in
+ Cifthenelse
+ (Cop (Ccmpf Ceq, [Cvar unboxed_id; Cop(Cload Double_u, [Cvar id])]),
+ Cvar id,
+ Csequence (Cassign (id, box_float (Cvar unboxed_id)),
+ Cvar id))
+
+ | Clet(id, arg, body) ->
+ let arg = subst arg in
+ if IdentSet.mem id ids then
+ let unboxed_id = create_unboxed_id id in
+ let body = subst body in
+ if IdentSet.mem id need_boxed then
+ Clet(id, arg, do_unbox id unboxed_id body)
+ else
+ Clet(unboxed_id, unbox_float arg, body)
+ else
+ Clet(id, arg, subst body)
+ | Cassign(id, arg) ->
+ if IdentSet.mem id ids then
+ let unboxed_id = get_unboxed_id id in
+ Cassign(unboxed_id, subst (unbox_float arg)) (* introduce extra unboxing *)
+ else
+ Cassign(id, subst arg)
+ | Ctuple argv -> Ctuple(List.map subst argv)
+ | (Cop(Cload _, [Cvar id]) | Cop(Cload _, [Cop(Cadda, [Cvar id; _])])) as e ->
+ if IdentSet.mem id ids then
+ Cvar (get_unboxed_id id)
+ else
+ e
+ | Cop(op, argv) -> Cop(op, List.map subst argv)
+ | Csequence(e1, e2) -> Csequence(subst e1, subst e2)
+ | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3)
+ | Cswitch(arg, index, cases) ->
+ Cswitch(subst arg, index, Array.map subst cases)
+ | Cloop e -> Cloop(subst e)
+ | Ccatch(nfail, bound_ids, body, handler) ->
+ let body = subst body in
+ let rec loop = function
+ | [] -> subst handler
+ | id :: rest when IdentSet.mem id ids ->
+ let unboxed_id = create_unboxed_id id in
+ do_unbox id unboxed_id (loop rest)
+ | id :: rest ->
+ loop rest
+ in
+ Ccatch(nfail, bound_ids, body, loop bound_ids)
+ | Cexit (nfail, el) -> Cexit (nfail, List.map subst el)
+ (* TODO: avoid boxing of exit-arguments if the boxed
+ version is not needed *)
+ | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2)
+ | (Cvar _ | Cconst_natpointer _ |Cconst_pointer _ |Cconst_symbol _ |Cconst_float _ | Cconst_natint _ |Cconst_int _) as e -> e
+ in
+ let body =
+ if IdentSet.is_empty ids then body else
+ begin
+ List.iter
+ (fun id ->
+ if IdentSet.mem id ids then
+ ignore (create_unboxed_id id)
+ ) params;
+ let body = subst body in
+ List.fold_left
+ (fun body id ->
+ if IdentSet.mem id ids then do_unbox id (get_unboxed_id id) body
+ else body
+ )
+ body params
+ end
+ in
+ loop body
+ in
+ try
+ let body = transl body in
+ loop body
+ with exn ->
+ unboxed_ids := IdentSet.empty;
+ raise exn
+
(* Translate a function definition *)
let transl_function f =
Cfunction {fun_name = f.label;
fun_args = List.map (fun id -> (id, typ_addr)) f.params;
- fun_body = transl f.body;
+ fun_body = transl_with_unboxing f.label f.params f.body;
fun_fast = !Clflags.optimize_for_speed;
- fun_dbg = f.dbg; }
+ fun_dbg = f.dbg; }
(* Translate all function definitions *)
@@ -1797,7 +2014,7 @@ let emit_all_constants cont =
let compunit size ulam =
let glob = Compilenv.make_symbol None in
- let init_code = transl ulam in
+ let init_code = transl_with_unboxing "entry" [] ulam in
let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry");
fun_args = [];
fun_body = init_code; fun_fast = false;
diff --git a/binary-compat/compat/3.11.2/.gitignore b/binary-compat/compat/3.11.2/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/binary-compat/compat/3.11.2/.gitignore
diff --git a/binary-compat/compat/3.12.0/.gitignore b/binary-compat/compat/3.12.0/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/binary-compat/compat/3.12.0/.gitignore
diff --git a/camlp4/camlp4/.gitignore b/camlp4/camlp4/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/camlp4/.gitignore
diff --git a/camlp4/etc/.gitignore b/camlp4/etc/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/etc/.gitignore
diff --git a/camlp4/lib/.gitignore b/camlp4/lib/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/lib/.gitignore
diff --git a/camlp4/meta/.gitignore b/camlp4/meta/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/meta/.gitignore
diff --git a/camlp4/ocaml_src/.gitignore b/camlp4/ocaml_src/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/ocaml_src/.gitignore
diff --git a/camlp4/ocaml_src/camlp4/.gitignore b/camlp4/ocaml_src/camlp4/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/ocaml_src/camlp4/.gitignore
diff --git a/camlp4/ocaml_src/lib/.gitignore b/camlp4/ocaml_src/lib/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/ocaml_src/lib/.gitignore
diff --git a/camlp4/ocaml_src/meta/.gitignore b/camlp4/ocaml_src/meta/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/ocaml_src/meta/.gitignore
diff --git a/camlp4/ocaml_src/odyl/.gitignore b/camlp4/ocaml_src/odyl/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/ocaml_src/odyl/.gitignore
diff --git a/camlp4/ocpp/.gitignore b/camlp4/ocpp/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/ocpp/.gitignore
diff --git a/camlp4/odyl/.gitignore b/camlp4/odyl/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/odyl/.gitignore
diff --git a/camlp4/top/.gitignore b/camlp4/top/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/camlp4/top/.gitignore
diff --git a/jocparsing/.gitignore b/jocparsing/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/jocparsing/.gitignore
diff --git a/maccaml/.gitignore b/maccaml/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/maccaml/.gitignore
diff --git a/otherlibs/join/.gitignore b/otherlibs/join/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/otherlibs/join/.gitignore
diff --git a/otherlibs/labltk/example/.gitignore b/otherlibs/labltk/example/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/otherlibs/labltk/example/.gitignore
diff --git a/otherlibs/num/test/.gitignore b/otherlibs/num/test/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/otherlibs/num/test/.gitignore
diff --git a/otherlibs/threads/Tests/.gitignore b/otherlibs/threads/Tests/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/otherlibs/threads/Tests/.gitignore
diff --git a/testasmcomp/.gitignore b/testasmcomp/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/testasmcomp/.gitignore
diff --git a/testsuite/tests/typing-gadts/.gitignore b/testsuite/tests/typing-gadts/.gitignore
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/testsuite/tests/typing-gadts/.gitignore
View Lorry Controller Status