| Anonymous | Login | Signup for a new account | 2013-06-19 14:18 CEST |  |
| Main | My View | View Issues | Change Log | Roadmap |
| View Issue Details [ Jump to Notes ] | [ Issue History ] [ Print ] | ||||||||||
| ID | Project | Category | View Status | Date Submitted | Last Update | ||||||
| 0004074 | OCaml | OCaml backend (code generation) | public | 2006-08-03 16:24 | 2012-07-04 18:53 | ||||||
| Reporter | frisch | ||||||||||
| Assigned To | |||||||||||
| Priority | normal | Severity | feature | Reproducibility | N/A | ||||||
| Status | acknowledged | Resolution | open | ||||||||
| Platform | OS | OS Version | |||||||||
| Product Version | |||||||||||
| Target Version | Fixed in Version | ||||||||||
| Summary | 0004074: Patch for in-place compilation of structures | ||||||||||
| Description | [edit: english translation] The attached patch adds an "-inplace" option to ocamlopt. When the option is set, it uses for all structures the same compilation scheme as is currently done for global structures only. This reduce pressure on the register allocater when compiling big structures. The patch is careful to adapt the inliner to the new way of filling structure fields. The program generated by the following code: print_string "module F(X:sig val x : int end) = struct\n let x0 = X.x";; for i = 1 to 300 do Printf.printf " let x%i = %i * x%i\n" i i (i-1) done;; print_string "end";; needs 15 seconds to compile with ocamlopt and 0.3s with option -inplace, and the generated .o goes from 15044 bytes to 12740 bytes. --- Le patch en pièce jointe ajoute une option "-inplace" à ocamlopt, dont l'effet est d'utiliser le schéma de compilation des structures globales pour toutes les structures. Ça permet de réduire la pression sur l'allocateur de registres lorsque l'on compile de grosses structures. Le patch prend soin d'adapter l'inliner pour qu'il comprenne la nouvelle manière de remplir les champs d'une structure. Le programme produit par: print_string "module F(X:sig val x : int end) = struct\n let x0 = X.x";; for i = 1 to 300 do Printf.printf " let x%i = %i * x%i\n" i i (i-1) done;; print_string "end";; prend 15s à compiler avec ocamlopt et 0.3s avec l'option -inplace, et le .o passe de 15044 octets à 12740 octets. | ||||||||||
| Tags | No tags attached. | ||||||||||
| Attached Files |  diff_inplace [^] (26,297 bytes) 2006-08-03 16:24 [Show Content] [Hide Content]diff -Naur ocaml/.depend ocaml_inplace/.depend
--- ocaml/.depend 2006-05-11 17:50:53.000000000 +0200
+++ ocaml_inplace/.depend 2006-08-03 14:34:01.000000000 +0200
@@ -112,11 +112,11 @@
typing/env.cmo: typing/types.cmi utils/tbl.cmi typing/subst.cmi \
typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
- typing/btype.cmi parsing/asttypes.cmi typing/env.cmi
+ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/env.cmi
typing/env.cmx: typing/types.cmx utils/tbl.cmx typing/subst.cmx \
typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \
typing/ident.cmx typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
- typing/btype.cmx parsing/asttypes.cmi typing/env.cmi
+ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/env.cmi
typing/ident.cmo: typing/ident.cmi
typing/ident.cmx: typing/ident.cmi
typing/includeclass.cmo: typing/types.cmi typing/printtyp.cmi \
@@ -415,13 +415,15 @@
typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
typing/path.cmi typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
- typing/ctype.cmi parsing/asttypes.cmi bytecomp/translmod.cmi
+ typing/ctype.cmi utils/clflags.cmi parsing/asttypes.cmi \
+ bytecomp/translmod.cmi
bytecomp/translmod.cmx: typing/types.cmx typing/typedtree.cmx \
bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \
typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
typing/path.cmx typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
- typing/ctype.cmx parsing/asttypes.cmi bytecomp/translmod.cmi
+ typing/ctype.cmx utils/clflags.cmx parsing/asttypes.cmi \
+ bytecomp/translmod.cmi
bytecomp/translobj.cmo: typing/primitive.cmi utils/misc.cmi \
parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
@@ -443,8 +445,8 @@
asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \
parsing/asttypes.cmi
asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi
-asmcomp/cmmgen.cmi: asmcomp/cmm.cmi asmcomp/clambda.cmi
asmcomp/cmm.cmi: typing/ident.cmi
+asmcomp/cmmgen.cmi: asmcomp/cmm.cmi asmcomp/clambda.cmi
asmcomp/codegen.cmi: asmcomp/cmm.cmi
asmcomp/comballoc.cmi: asmcomp/mach.cmi
asmcomp/compilenv.cmi: typing/ident.cmi asmcomp/clambda.cmi
@@ -458,8 +460,8 @@
asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/proc.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/reg.cmi: asmcomp/cmm.cmi
-asmcomp/reloadgen.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/reload.cmi: asmcomp/mach.cmi
+asmcomp/reloadgen.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/schedgen.cmi: asmcomp/mach.cmi asmcomp/linearize.cmi
asmcomp/scheduling.cmi: asmcomp/linearize.cmi
asmcomp/selectgen.cmi: utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
@@ -523,6 +525,8 @@
utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/compilenv.cmx \
utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \
asmcomp/closure.cmi
+asmcomp/cmm.cmo: typing/ident.cmi asmcomp/arch.cmo asmcomp/cmm.cmi
+asmcomp/cmm.cmx: typing/ident.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
asmcomp/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \
typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi \
@@ -533,8 +537,6 @@
utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx \
asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
asmcomp/cmmgen.cmi
-asmcomp/cmm.cmo: typing/ident.cmi asmcomp/arch.cmo asmcomp/cmm.cmi
-asmcomp/cmm.cmx: typing/ident.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
asmcomp/codegen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \
asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \
asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \
@@ -555,8 +557,6 @@
utils/config.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi
asmcomp/compilenv.cmx: utils/misc.cmx typing/ident.cmx typing/env.cmx \
utils/config.cmx asmcomp/clambda.cmx asmcomp/compilenv.cmi
-asmcomp/emitaux.cmo: asmcomp/emitaux.cmi
-asmcomp/emitaux.cmx: asmcomp/emitaux.cmi
asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi parsing/location.cmi asmcomp/linearize.cmi \
asmcomp/emitaux.cmi utils/config.cmi asmcomp/compilenv.cmi \
@@ -565,6 +565,8 @@
asmcomp/mach.cmx parsing/location.cmx asmcomp/linearize.cmx \
asmcomp/emitaux.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi
+asmcomp/emitaux.cmo: asmcomp/emitaux.cmi
+asmcomp/emitaux.cmx: asmcomp/emitaux.cmi
asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/interf.cmi
asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
@@ -599,14 +601,14 @@
asmcomp/arch.cmx asmcomp/proc.cmi
asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi
asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi
-asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
- asmcomp/reloadgen.cmi
-asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
- asmcomp/reloadgen.cmi
asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi
asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi
+asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
+ asmcomp/reloadgen.cmi
+asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
+ asmcomp/reloadgen.cmi
asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
asmcomp/schedgen.cmi
@@ -665,8 +667,6 @@
parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \
typing/env.cmx typing/ctype.cmx bytecomp/bytepackager.cmx \
bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/errors.cmi
-driver/main_args.cmo: driver/main_args.cmi
-driver/main_args.cmx: driver/main_args.cmi
driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
driver/errors.cmi utils/config.cmi driver/compile.cmi utils/clflags.cmi \
bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
@@ -675,6 +675,8 @@
driver/errors.cmx utils/config.cmx driver/compile.cmx utils/clflags.cmx \
bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx driver/main.cmi
+driver/main_args.cmo: driver/main_args.cmi
+driver/main_args.cmx: driver/main_args.cmi
driver/optcompile.cmo: utils/warnings.cmi typing/unused_var.cmi \
typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \
bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
diff -Naur ocaml/asmcomp/closure.ml ocaml_inplace/asmcomp/closure.ml
--- ocaml/asmcomp/closure.ml 2006-01-04 17:55:49.000000000 +0100
+++ ocaml_inplace/asmcomp/closure.ml 2006-08-03 16:04:49.000000000 +0200
@@ -545,6 +545,7 @@
(Uprim(prim, ulams),
begin match mut with
Immutable -> Value_tuple(Array.of_list approxs)
+ | WriteOnce -> Value_tuple(Array.make (List.length lams) Value_unknown)
| Mutable -> Value_unknown
end)
| Lprim(Pfield n, [lam]) ->
@@ -554,10 +555,14 @@
Value_tuple a when n < Array.length a -> a.(n)
| _ -> Value_unknown in
check_constant_result lam (Uprim(Pfield n, [ulam])) fieldapprox
- | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) ->
- let (ulam, approx) = close fenv cenv lam in
- (!global_approx).(n) <- approx;
- (Uprim(Psetfield(n, false), [getglobal id; ulam]),
+ | Lprim(Psetfield(n, isptr), [lam1;lam2]) ->
+ let is_global = match lam1 with Lprim(Pgetglobal _, _) -> true | _ -> false in
+ let (ulam1, approx1) = close fenv cenv lam1 in
+ let (ulam2, approx2) = close fenv cenv lam2 in
+ (match approx1 with
+ | Value_tuple a -> assert(a.(n) = Value_unknown); a.(n) <- approx2
+ | _ -> ());
+ (Uprim(Psetfield(n, isptr && not is_global), [ulam1;ulam2]),
Value_unknown)
| Lprim(p, args) ->
simplif_prim p (close_list_approx fenv cenv args)
diff -Naur ocaml/asmcomp/cmmgen.ml ocaml_inplace/asmcomp/cmmgen.ml
--- ocaml/asmcomp/cmmgen.ml 2006-04-17 01:28:14.000000000 +0200
+++ ocaml_inplace/asmcomp/cmmgen.ml 2006-08-03 15:47:37.000000000 +0200
@@ -334,6 +334,10 @@
(* Allocation *)
+let caml_alloc tag len =
+ Cop(Cextcall("caml_alloc", typ_addr, true),
+ [Cconst_int len; Cconst_int tag])
+
let make_alloc_generic set_fn tag wordsize args =
if wordsize <= Config.max_young_wosize then
Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args)
@@ -343,10 +347,7 @@
[] -> Cvar id
| e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1,
fill_fields (idx + 2) el) in
- Clet(id,
- Cop(Cextcall("caml_alloc", typ_addr, true),
- [Cconst_int wordsize; Cconst_int tag]),
- fill_fields 1 args)
+ Clet(id, caml_alloc tag wordsize, fill_fields 1 args)
end
let make_alloc tag args =
@@ -856,6 +857,8 @@
Cconst_symbol (Ident.name id)
| (Pmakeblock(tag, mut), []) ->
transl_constant(Const_block(tag, []))
+ | (Pmakeblock(tag, WriteOnce), args) ->
+ caml_alloc tag (List.length args)
| (Pmakeblock(tag, mut), args) ->
make_alloc tag (List.map transl args)
| (Pccall prim, args) ->
diff -Naur ocaml/bytecomp/lambda.ml ocaml_inplace/bytecomp/lambda.ml
--- ocaml/bytecomp/lambda.ml 2005-08-25 17:35:16.000000000 +0200
+++ ocaml_inplace/bytecomp/lambda.ml 2006-08-03 14:23:45.000000000 +0200
@@ -16,6 +16,11 @@
open Path
open Asttypes
+type block_type =
+ | Immutable
+ | Mutable
+ | WriteOnce
+
type primitive =
Pidentity
| Pignore
@@ -23,7 +28,7 @@
| Pgetglobal of Ident.t
| Psetglobal of Ident.t
(* Operations on heap blocks *)
- | Pmakeblock of int * mutable_flag
+ | Pmakeblock of int * block_type
| Pfield of int
| Psetfield of int * bool
| Pfloatfield of int
@@ -236,7 +241,7 @@
Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in
name_list [] args
-let rec iter f = function
+let iter f = function
Lvar _
| Lconst _ -> ()
| Lapply(fn, args) ->
diff -Naur ocaml/bytecomp/lambda.mli ocaml_inplace/bytecomp/lambda.mli
--- ocaml/bytecomp/lambda.mli 2005-08-25 17:35:16.000000000 +0200
+++ ocaml_inplace/bytecomp/lambda.mli 2006-08-03 14:23:19.000000000 +0200
@@ -16,6 +16,11 @@
open Asttypes
+type block_type =
+ | Immutable
+ | Mutable
+ | WriteOnce
+
type primitive =
Pidentity
| Pignore
@@ -23,7 +28,7 @@
| Pgetglobal of Ident.t
| Psetglobal of Ident.t
(* Operations on heap blocks *)
- | Pmakeblock of int * mutable_flag
+ | Pmakeblock of int * block_type
| Pfield of int
| Psetfield of int * bool
| Pfloatfield of int
diff -Naur ocaml/bytecomp/matching.ml ocaml_inplace/bytecomp/matching.ml
--- ocaml/bytecomp/matching.ml 2005-09-07 18:07:48.000000000 +0200
+++ ocaml_inplace/bytecomp/matching.ml 2006-08-03 14:24:29.000000000 +0200
@@ -1350,8 +1350,8 @@
| Record_float -> Pfloatfield lbl.lbl_pos in
let str =
match lbl.lbl_mut with
- Immutable -> Alias
- | Mutable -> StrictOpt in
+ Asttypes.Immutable -> Alias
+ | Asttypes.Mutable -> StrictOpt in
(Lprim(access, [arg]), str) :: make_args(pos + 1)
end in
let nfields = Array.length all_labels in
diff -Naur ocaml/bytecomp/printlambda.ml ocaml_inplace/bytecomp/printlambda.ml
--- ocaml/bytecomp/printlambda.ml 2005-08-25 17:35:16.000000000 +0200
+++ ocaml_inplace/bytecomp/printlambda.ml 2006-08-03 14:24:06.000000000 +0200
@@ -90,6 +90,7 @@
| Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
| Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag
| Pmakeblock(tag, Mutable) -> fprintf ppf "makemutable %i" tag
+ | Pmakeblock(tag, WriteOnce) -> fprintf ppf "makeblock* %i" tag
| Pfield n -> fprintf ppf "field %i" n
| Psetfield(n, ptr) ->
let instr = if ptr then "setfield_ptr " else "setfield_imm " in
diff -Naur ocaml/bytecomp/translcore.ml ocaml_inplace/bytecomp/translcore.ml
--- ocaml/bytecomp/translcore.ml 2006-01-27 15:33:42.000000000 +0100
+++ ocaml_inplace/bytecomp/translcore.ml 2006-08-03 14:24:42.000000000 +0200
@@ -879,7 +879,7 @@
lbl_expr_list;
let ll = Array.to_list lv in
let mut =
- if List.exists (fun (lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list
+ if List.exists (fun (lbl, expr) -> lbl.lbl_mut = Asttypes.Mutable) lbl_expr_list
then Mutable
else Immutable in
let lam =
diff -Naur ocaml/bytecomp/translmod.ml ocaml_inplace/bytecomp/translmod.ml
--- ocaml/bytecomp/translmod.ml 2006-04-05 04:28:12.000000000 +0200
+++ ocaml_inplace/bytecomp/translmod.ml 2006-08-03 14:40:26.000000000 +0200
@@ -32,6 +32,63 @@
exception Error of Location.t * error
+(* Build the list of value identifiers defined by a toplevel structure
+ (excluding primitive declarations). *)
+
+let rec defined_idents = function
+ [] -> []
+ | Tstr_eval expr :: rem -> defined_idents rem
+ | Tstr_value(rec_flag, pat_expr_list) :: rem ->
+ let_bound_idents pat_expr_list @ defined_idents rem
+ | Tstr_primitive(id, descr) :: rem -> defined_idents rem
+ | Tstr_type decls :: rem -> defined_idents rem
+ | Tstr_exception(id, decl) :: rem -> id :: defined_idents rem
+ | Tstr_exn_rebind(id, path) :: rem -> id :: defined_idents rem
+ | Tstr_module(id, modl) :: rem -> id :: defined_idents rem
+ | Tstr_recmodule decls :: rem -> List.map fst decls @ defined_idents rem
+ | Tstr_modtype(id, decl) :: rem -> defined_idents rem
+ | Tstr_open path :: rem -> defined_idents rem
+ | Tstr_class cl_list :: rem ->
+ List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem
+ | Tstr_cltype cl_list :: rem -> defined_idents rem
+ | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem
+
+(* Transform a coercion and the list of value identifiers defined by
+ a toplevel structure into a table [id -> (pos, coercion)],
+ with [pos] being the position in the global block where the value of
+ [id] must be stored, and [coercion] the coercion to be applied to it.
+ A given identifier may appear several times
+ in the coercion (if it occurs several times in the signature); remember
+ to assign it the position of its last occurrence.
+ Identifiers that are not exported are assigned positions at the
+ end of the block (beyond the positions of all exported idents).
+ Also compute the total size of the global block,
+ and the list of all primitives exported as values. *)
+
+let build_ident_map restr idlist =
+ let rec natural_map pos map prims = function
+ [] ->
+ (map, prims, pos)
+ | id :: rem ->
+ natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in
+ match restr with
+ Tcoerce_none ->
+ natural_map 0 Ident.empty [] idlist
+ | Tcoerce_structure pos_cc_list ->
+ let idarray = Array.of_list idlist in
+ let rec export_map pos map prims undef = function
+ [] ->
+ natural_map pos map prims undef
+ | (source_pos, Tcoerce_primitive p) :: rem ->
+ export_map (pos + 1) map ((pos, p) :: prims) undef rem
+ | (source_pos, cc) :: rem ->
+ let id = idarray.(source_pos) in
+ export_map (pos + 1) (Ident.add id (pos, cc) map)
+ prims (list_remove id undef) rem
+ in export_map 0 Ident.empty [] idlist pos_cc_list
+ | _ ->
+ fatal_error "Translmod.build_ident_map"
+
(* Compile a coercion *)
let rec apply_coercion restr arg =
@@ -238,7 +295,7 @@
Tmod_ident path ->
apply_coercion cc (transl_path path)
| Tmod_structure str ->
- transl_structure [] cc rootpath str
+ transl_str cc rootpath str
| Tmod_functor(param, mty, body) ->
let bodypath = functor_path rootpath param in
oo_wrap mexp.mod_env true
@@ -262,6 +319,10 @@
| Tmod_constraint(arg, mty, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
+and transl_str cc rootpath str =
+ if !Clflags.module_inplace then transl_store_structure cc rootpath str
+ else transl_structure [] cc rootpath str
+
and transl_structure fields cc rootpath = function
[] ->
begin match cc with
@@ -336,20 +397,6 @@
Llet(Alias, mid, transl_module Tcoerce_none None modl,
rebind_idents 0 fields ids)
-(* Update forward declaration in Translcore *)
-let _ =
- Translcore.transl_module := transl_module
-
-(* Compile an implementation *)
-
-let transl_implementation module_name (str, cc) =
- reset_labels ();
- primitive_declarations := [];
- let module_id = Ident.create_persistent module_name in
- Lprim(Psetglobal module_id,
- [transl_label_init
- (transl_structure [] cc (global_path module_id) str)])
-
(* A variant of transl_structure used to compile toplevel structure definitions
for the native-code compiler. Store the defined values in the fields
of the global as soon as they are defined, in order to reduce register
@@ -359,7 +406,20 @@
"map" is a table from defined idents to (pos in global block, coercion).
"prim" is a list of (pos in global block, primitive declaration). *)
-let transl_store_structure glob map prims str =
+and transl_store_structure cc rootpath str =
+ let (map, prims, size) = build_ident_map cc (defined_idents str) in
+ let rec init = function 0 -> [] | n ->
+ Lconst(Const_pointer 0) :: init (n - 1) in
+ let id = Ident.create "struct" in
+ Llet (Strict, id,
+ Lprim(Pmakeblock(0, WriteOnce), init size),
+ Lsequence (
+ transl_store_structure_aux (Lvar id) rootpath map prims Ident.empty
+ str,
+ Lvar id)
+ )
+
+and transl_store_structure_aux block path map prims subst str =
let rec transl_store subst = function
[] ->
lambda_unit
@@ -381,16 +441,17 @@
| Tstr_type(decls) :: rem ->
transl_store subst rem
| Tstr_exception(id, decl) :: rem ->
- let lam = transl_exception id (field_path (global_path glob) id) decl in
+ let lam = transl_exception id (field_path path id) decl in
Lsequence(Llet(Strict, id, lam, store_ident id),
transl_store (add_ident false id subst) rem)
| Tstr_exn_rebind(id, path) :: rem ->
let lam = subst_lambda subst (transl_path path) in
Lsequence(Llet(Strict, id, lam, store_ident id),
transl_store (add_ident false id subst) rem)
+
| Tstr_module(id, modl) :: rem ->
let lam =
- transl_module Tcoerce_none (field_path (global_path glob) id) modl in
+ transl_module Tcoerce_none (field_path path id) modl in
(* Careful: the module value stored in the global may be different
from the local module value, in case a coercion is applied.
If so, keep using the local module value (id) in the remainder of
@@ -405,7 +466,7 @@
(fun id modl ->
subst_lambda subst
(transl_module Tcoerce_none
- (field_path (global_path glob) id) modl))
+ (field_path path id) modl))
bindings
(Lsequence(store_idents ids,
transl_store (add_idents true ids subst) rem))
@@ -440,7 +501,7 @@
try
let (pos, cc) = Ident.find_same id map in
let init_val = apply_coercion cc (Lvar id) in
- Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val])
+ Lprim(Psetfield(pos, true), [block; init_val])
with Not_found ->
fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)
@@ -452,7 +513,7 @@
let (pos, cc) = Ident.find_same id map in
match cc with
Tcoerce_none ->
- Ident.add id (Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])])) subst
+ Ident.add id (Lprim(Pfield pos, [block])) subst
| _ ->
if may_coerce then subst else assert false
with Not_found ->
@@ -462,68 +523,26 @@
List.fold_right (add_ident may_coerce) idlist subst
and store_primitive (pos, prim) cont =
- Lsequence(Lprim(Psetfield(pos, false),
- [Lprim(Pgetglobal glob, []); transl_primitive prim]),
+ Lsequence(Lprim(Psetfield(pos, true),
+ [block; transl_primitive prim]),
cont)
- in List.fold_right store_primitive prims (transl_store Ident.empty str)
+ in List.fold_right store_primitive prims (transl_store subst str)
-(* Build the list of value identifiers defined by a toplevel structure
- (excluding primitive declarations). *)
+(* Update forward declaration in Translcore *)
+let _ =
+ Translcore.transl_module := transl_module
-let rec defined_idents = function
- [] -> []
- | Tstr_eval expr :: rem -> defined_idents rem
- | Tstr_value(rec_flag, pat_expr_list) :: rem ->
- let_bound_idents pat_expr_list @ defined_idents rem
- | Tstr_primitive(id, descr) :: rem -> defined_idents rem
- | Tstr_type decls :: rem -> defined_idents rem
- | Tstr_exception(id, decl) :: rem -> id :: defined_idents rem
- | Tstr_exn_rebind(id, path) :: rem -> id :: defined_idents rem
- | Tstr_module(id, modl) :: rem -> id :: defined_idents rem
- | Tstr_recmodule decls :: rem -> List.map fst decls @ defined_idents rem
- | Tstr_modtype(id, decl) :: rem -> defined_idents rem
- | Tstr_open path :: rem -> defined_idents rem
- | Tstr_class cl_list :: rem ->
- List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem
- | Tstr_cltype cl_list :: rem -> defined_idents rem
- | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem
+(* Compile an implementation *)
-(* Transform a coercion and the list of value identifiers defined by
- a toplevel structure into a table [id -> (pos, coercion)],
- with [pos] being the position in the global block where the value of
- [id] must be stored, and [coercion] the coercion to be applied to it.
- A given identifier may appear several times
- in the coercion (if it occurs several times in the signature); remember
- to assign it the position of its last occurrence.
- Identifiers that are not exported are assigned positions at the
- end of the block (beyond the positions of all exported idents).
- Also compute the total size of the global block,
- and the list of all primitives exported as values. *)
+let transl_implementation module_name (str, cc) =
+ reset_labels ();
+ primitive_declarations := [];
+ let module_id = Ident.create_persistent module_name in
+ Lprim(Psetglobal module_id,
+ [transl_label_init
+ (transl_str cc (global_path module_id) str)])
-let build_ident_map restr idlist =
- let rec natural_map pos map prims = function
- [] ->
- (map, prims, pos)
- | id :: rem ->
- natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in
- match restr with
- Tcoerce_none ->
- natural_map 0 Ident.empty [] idlist
- | Tcoerce_structure pos_cc_list ->
- let idarray = Array.of_list idlist in
- let rec export_map pos map prims undef = function
- [] ->
- natural_map pos map prims undef
- | (source_pos, Tcoerce_primitive p) :: rem ->
- export_map (pos + 1) map ((pos, p) :: prims) undef rem
- | (source_pos, cc) :: rem ->
- let id = idarray.(source_pos) in
- export_map (pos + 1) (Ident.add id (pos, cc) map)
- prims (list_remove id undef) rem
- in export_map 0 Ident.empty [] idlist pos_cc_list
- | _ ->
- fatal_error "Translmod.build_ident_map"
(* Compile an implementation using transl_store_structure
(for the native-code compiler). *)
@@ -534,7 +553,8 @@
let module_id = Ident.create_persistent module_name in
let (map, prims, size) = build_ident_map restr (defined_idents str) in
transl_store_label_init module_id size
- (transl_store_structure module_id map prims) str
+ (transl_store_structure_aux (Lprim(Pgetglobal module_id, []))
+ (global_path module_id) map prims Ident.empty ) str
(*size, transl_label_init (transl_store_structure module_id map prims str)*)
(* Compile a toplevel phrase *)
diff -Naur ocaml/driver/optmain.ml ocaml_inplace/driver/optmain.ml
--- ocaml/driver/optmain.ml 2006-04-05 04:28:13.000000000 +0200
+++ ocaml_inplace/driver/optmain.ml 2006-08-03 14:28:28.000000000 +0200
@@ -128,6 +128,8 @@
"<file> Suffix for interface files (default: .mli)";
"-intf_suffix", Arg.String (fun s -> Config.interface_suffix := s),
"<file> (deprecated) same as -intf-suffix";
+ "-inplace", Arg.Set module_inplace,
+ " compile structures in place";
"-labels", Arg.Clear classic, " Use commuting label mode";
"-linkall", Arg.Set link_everything,
" Link all modules, even unused ones";
diff -Naur ocaml/utils/clflags.ml ocaml_inplace/utils/clflags.ml
--- ocaml/utils/clflags.ml 2005-08-01 17:51:09.000000000 +0200
+++ ocaml_inplace/utils/clflags.ml 2006-08-03 14:30:05.000000000 +0200
@@ -88,3 +88,5 @@
let std_include_dir () =
if !no_std_include then [] else [Config.standard_library]
;;
+
+let module_inplace = ref false (* -inplace *)
diff -Naur ocaml/utils/clflags.mli ocaml_inplace/utils/clflags.mli
--- ocaml/utils/clflags.mli 2005-10-26 15:23:27.000000000 +0200
+++ ocaml_inplace/utils/clflags.mli 2006-08-03 14:29:54.000000000 +0200
@@ -73,3 +73,4 @@
val dont_write_files : bool ref
val std_include_flag : string -> string
val std_include_dir : unit -> string list
+val module_inplace : bool ref
| ||||||||||
 Relationships |
|||||||||||
|
|||||||||||
 Relationships |
|
Notes |
|
|
(0003727) frisch (developer) 2006-08-05 11:17 edited on: 2012-04-05 06:11 |
You have to remove the assertion (assert(a.(n) = Value_unknown) so that it still works without -inplace. |
|
(0003730) frisch (developer) 2006-08-08 19:15 edited on: 2012-04-05 06:12 |
For the record, the patch compiles Ocamlr.ml for example in 7 seconds, against 21s without the patch. It is mostly the computation of the register interference graph which makes the difference. |
|
Notes |
|
Issue History |
|||
| Date Modified | Username | Field | Change |
| 2006-08-03 16:24 | frisch | New Issue | |
| 2006-08-03 16:24 | frisch | File Added: diff_inplace | |
| 2006-08-05 11:17 | frisch | Note Added: 0003727 | |
| 2006-08-08 19:15 | frisch | Note Added: 0003730 | |
| 2006-08-29 16:40 | doligez | Status | new => acknowledged |
| 2012-03-29 09:29 | frisch | Relationship added | related to 0005546 |
| 2012-04-04 22:47 | gasche | Relationship added | related to 0005573 |
| 2012-04-05 06:09 | gasche | Severity | minor => feature |
| 2012-04-05 06:09 | gasche | Summary | Patch pour compiler les structures en place => Patch for in-place compilation of structures |
| 2012-04-05 06:09 | gasche | Description Updated | View Revisions |
| 2012-04-05 06:11 | gasche | Note Edited: 0003727 | View Revisions |
| 2012-04-05 06:12 | gasche | Note Edited: 0003730 | View Revisions |
| 2012-06-20 11:19 | frisch | Category | OCaml general => OCaml backend (code generation) |
|
Issue History |
| Copyright © 2000 - 2011 MantisBT Group |
 |