summaryrefslogtreecommitdiff
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/bytegen.ml23
-rw-r--r--bytecomp/bytelink.ml29
-rw-r--r--bytecomp/bytepackager.ml101
-rw-r--r--bytecomp/emitcode.ml2
-rw-r--r--bytecomp/instruct.ml2
-rw-r--r--bytecomp/instruct.mli2
-rw-r--r--bytecomp/lambda.ml9
-rw-r--r--bytecomp/lambda.mli4
-rw-r--r--bytecomp/matching.ml20
-rw-r--r--bytecomp/matching.mli4
-rw-r--r--bytecomp/meta.ml1
-rw-r--r--bytecomp/meta.mli1
-rw-r--r--bytecomp/printinstr.ml2
-rw-r--r--bytecomp/printlambda.ml6
-rw-r--r--bytecomp/simplif.ml12
-rw-r--r--bytecomp/translclass.ml113
-rw-r--r--bytecomp/translclass.mli2
-rw-r--r--bytecomp/translcore.ml68
-rw-r--r--bytecomp/translmod.ml24
-rw-r--r--bytecomp/translmod.mli5
-rw-r--r--bytecomp/translobj.ml83
-rw-r--r--bytecomp/translobj.mli4
-rw-r--r--bytecomp/typeopt.ml3
23 files changed, 330 insertions, 190 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index cdc4c9e287..8a8652488c 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -409,20 +409,27 @@ let rec comp_expr env exp sz cont =
(Kpush :: comp_expr env func (sz + 3 + nargs)
(Kapply nargs :: cont1))
end
- | Lsend(met, obj, args) ->
+ | Lsend(kind, met, obj, args) ->
+ let args = if kind = Cached then List.tl args else args in
let nargs = List.length args + 1 in
+ let getmethod, args' =
+ if kind = Self then (Kgetmethod, met::obj::args) else
+ match met with
+ Lconst(Const_base(Const_int n)) -> (Kgetpubmet n, obj::args)
+ | _ -> (Kgetdynmet, met::obj::args)
+ in
if is_tailcall cont then
- comp_args env (met::obj::args) sz
- (Kgetmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont)
+ comp_args env args' sz
+ (getmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont)
else
if nargs < 4 then
- comp_args env (met::obj::args) sz
- (Kgetmethod :: Kapply nargs :: cont)
+ comp_args env args' sz
+ (getmethod :: Kapply nargs :: cont)
else begin
let (lbl, cont1) = label_code cont in
Kpush_retaddr lbl ::
- comp_args env (met::obj::args) (sz + 3)
- (Kgetmethod :: Kapply nargs :: cont1)
+ comp_args env args' (sz + 3)
+ (getmethod :: Kapply nargs :: cont1)
end
| Lfunction(kind, params, body) -> (* assume kind = Curried *)
let lbl = new_label() in
@@ -714,7 +721,7 @@ let rec comp_expr env exp sz cont =
let info =
match lam with
Lapply(_, args) -> Event_return (List.length args)
- | Lsend(_, _, args) -> Event_return (List.length args + 1)
+ | Lsend(_, _, _, args) -> Event_return (List.length args + 1)
| _ -> Event_other
in
let ev = event (Event_after ty) info in
diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 66f844615c..25bf10453e 100644
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -468,35 +468,6 @@ let build_custom_runtime prim_name exec_name =
remove_file
(Filename.chop_suffix (Filename.basename prim_name) ".c" ^ ".obj");
retcode
- | "mrc" ->
- let cppc = "mrc"
- and libsppc = "\"{sharedlibraries}MathLib\" \
- \"{ppclibraries}PPCCRuntime.o\" \
- \"{ppclibraries}PPCToolLibs.o\" \
- \"{sharedlibraries}StdCLib\" \
- \"{ppclibraries}StdCRuntime.o\" \
- \"{sharedlibraries}InterfaceLib\""
- and linkppc = "ppclink -d"
- and objsppc = extract ".x" (List.rev !Clflags.ccobjs)
- and q_prim_name = Filename.quote prim_name
- and q_exec_name = Filename.quote exec_name
- in
- Ccomp.run_command (Printf.sprintf "%s %s %s %s -o %s.x"
- cppc
- (Clflags.std_include_flag "-i ")
- (String.concat " " (List.rev_map Filename.quote !Clflags.ccopts))
- q_prim_name
- q_prim_name);
- Ccomp.run_command ("delete -i " ^ q_exec_name);
- Ccomp.command (Printf.sprintf
- "%s -t MPST -c 'MPS ' -o %s %s.x %s %s %s"
- linkppc
- q_exec_name
- q_prim_name
- (String.concat " " (List.map Filename.quote objsppc))
- (Filename.quote
- (Filename.concat Config.standard_library "libcamlrun.x"))
- libsppc)
| _ -> assert false
let append_bytecode_and_cleanup bytecode_name exec_name prim_name =
diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
index 450321ac76..57b8371a5b 100644
--- a/bytecomp/bytepackager.ml
+++ b/bytecomp/bytepackager.ml
@@ -72,24 +72,37 @@ let relocate_debug base ev =
(* Read the unit information from a .cmo file. *)
-let read_unit_info objfile =
- let ic = open_in_bin objfile in
- try
- let buffer = String.create (String.length Config.cmo_magic_number) in
- really_input ic buffer 0 (String.length Config.cmo_magic_number);
- if buffer <> Config.cmo_magic_number then
- raise(Error(Not_an_object_file objfile));
- let compunit_pos = input_binary_int ic in
- seek_in ic compunit_pos;
- let compunit = (input_value ic : compilation_unit) in
- if compunit.cu_name
- <> String.capitalize(Filename.basename(chop_extension_if_any objfile))
- then raise(Error(Illegal_renaming(objfile, compunit.cu_name)));
- close_in ic;
- compunit
- with x ->
- close_in ic;
- raise x
+type pack_member_kind = PM_intf | PM_impl of compilation_unit
+
+type pack_member =
+ { pm_file: string;
+ pm_name: string;
+ pm_kind: pack_member_kind }
+
+let read_member_info file =
+ let name =
+ String.capitalize(Filename.basename(chop_extension_if_any file)) in
+ let kind =
+ if Filename.check_suffix file ".cmo" then begin
+ let ic = open_in_bin file in
+ try
+ let buffer = String.create (String.length Config.cmo_magic_number) in
+ really_input ic buffer 0 (String.length Config.cmo_magic_number);
+ if buffer <> Config.cmo_magic_number then
+ raise(Error(Not_an_object_file file));
+ let compunit_pos = input_binary_int ic in
+ seek_in ic compunit_pos;
+ let compunit = (input_value ic : compilation_unit) in
+ if compunit.cu_name <> name
+ then raise(Error(Illegal_renaming(file, compunit.cu_name)));
+ close_in ic;
+ PM_impl compunit
+ with x ->
+ close_in ic;
+ raise x
+ end else
+ PM_intf in
+ { pm_file = file; pm_name = name; pm_kind = kind }
(* Read the bytecode from a .cmo file.
Write bytecode to channel [oc].
@@ -97,7 +110,7 @@ let read_unit_info objfile =
Accumulate relocs, debug info, etc.
Return size of bytecode. *)
-let rename_append_bytecode oc mapping defined ofs (objfile, compunit) =
+let rename_append_bytecode oc mapping defined ofs objfile compunit =
let ic = open_in_bin objfile in
try
Bytelink.check_consistency objfile compunit;
@@ -118,23 +131,37 @@ let rename_append_bytecode oc mapping defined ofs (objfile, compunit) =
close_in ic;
raise x
-(* Same, for a list of .cmo files. Return total size of bytecode. *)
+(* Same, for a list of .cmo and .cmi files.
+ Return total size of bytecode. *)
let rec rename_append_bytecode_list oc mapping defined ofs = function
[] ->
ofs
- | ((objfile, compunit) as obj_unit) :: rem ->
- let size = rename_append_bytecode oc mapping defined ofs obj_unit in
- rename_append_bytecode_list
- oc mapping (Ident.create_persistent compunit.cu_name :: defined)
- (ofs + size) rem
+ | m :: rem ->
+ match m.pm_kind with
+ | PM_intf ->
+ rename_append_bytecode_list oc mapping defined ofs rem
+ | PM_impl compunit ->
+ let size =
+ rename_append_bytecode oc mapping defined ofs
+ m.pm_file compunit in
+ rename_append_bytecode_list
+ oc mapping (Ident.create_persistent m.pm_name :: defined)
+ (ofs + size) rem
(* Generate the code that builds the tuple representing the package module *)
-let build_global_target oc target_name mapping pos coercion =
+let build_global_target oc target_name members mapping pos coercion =
+ let components =
+ List.map2
+ (fun m (id1, id2) ->
+ match m.pm_kind with
+ | PM_intf -> None
+ | PM_impl _ -> Some id2)
+ members mapping in
let lam =
- Translmod.transl_package (List.map snd mapping)
- (Ident.create_persistent target_name) coercion in
+ Translmod.transl_package
+ components (Ident.create_persistent target_name) coercion in
let instrs =
Bytegen.compile_implementation target_name lam in
let rel =
@@ -143,11 +170,11 @@ let build_global_target oc target_name mapping pos coercion =
(* Build the .cmo file obtained by packaging the given .cmo files. *)
-let package_object_files objfiles targetfile targetname coercion =
- let units =
- List.map (fun f -> (f, read_unit_info f)) objfiles in
+let package_object_files files targetfile targetname coercion =
+ let members =
+ map_left_right read_member_info files in
let unit_names =
- List.map (fun (_, cu) -> cu.cu_name) units in
+ List.map (fun m -> m.pm_name) members in
let mapping =
List.map
(fun name ->
@@ -160,8 +187,8 @@ let package_object_files objfiles targetfile targetname coercion =
let pos_depl = pos_out oc in
output_binary_int oc 0;
let pos_code = pos_out oc in
- let ofs = rename_append_bytecode_list oc mapping [] 0 units in
- build_global_target oc targetname mapping ofs coercion;
+ let ofs = rename_append_bytecode_list oc mapping [] 0 members in
+ build_global_target oc targetname members mapping ofs coercion;
let pos_debug = pos_out oc in
if !Clflags.debug && !events <> [] then
output_value oc (List.rev !events);
@@ -191,7 +218,7 @@ let package_object_files objfiles targetfile targetname coercion =
(* The entry point *)
let package_files files targetfile =
- let objfiles =
+ let files =
List.map
(fun f ->
try find_in_path !Config.load_path f
@@ -201,8 +228,8 @@ let package_files files targetfile =
let targetcmi = prefix ^ ".cmi" in
let targetname = String.capitalize(Filename.basename prefix) in
try
- let coercion = Typemod.package_units objfiles targetcmi targetname in
- package_object_files objfiles targetfile targetname coercion
+ let coercion = Typemod.package_units files targetcmi targetname in
+ package_object_files files targetfile targetname coercion
with x ->
remove_file targetfile; raise x
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index a2ee15a820..bd56ca6425 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -293,6 +293,8 @@ let emit_instr = function
| Kisint -> out opISINT
| Kisout -> out opULTINT
| Kgetmethod -> out opGETMETHOD
+ | Kgetpubmet tag -> out opGETPUBMET; out_int tag; out_int 0
+ | Kgetdynmet -> out opGETDYNMET
| Kevent ev -> record_event ev
| Kstop -> out opSTOP
diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
index 81224dde6f..fd13db5d7a 100644
--- a/bytecomp/instruct.ml
+++ b/bytecomp/instruct.ml
@@ -97,6 +97,8 @@ type instruction =
| Kisint
| Kisout
| Kgetmethod
+ | Kgetpubmet of int
+ | Kgetdynmet
| Kevent of debug_event
| Kstop
diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
index f609d5d94b..fdedd8fd47 100644
--- a/bytecomp/instruct.mli
+++ b/bytecomp/instruct.mli
@@ -116,6 +116,8 @@ type instruction =
| Kisint
| Kisout
| Kgetmethod
+ | Kgetpubmet of int
+ | Kgetdynmet
| Kevent of debug_event
| Kstop
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 9a2770f10d..7f537ddf2b 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -115,6 +115,8 @@ type function_kind = Curried | Tupled
type let_kind = Strict | Alias | StrictOpt | Variable
+type meth_kind = Self | Public | Cached
+
type shared_code = (int * int) list
type lambda =
@@ -134,7 +136,7 @@ type lambda =
| Lwhile of lambda * lambda
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
| Lassign of Ident.t * lambda
- | Lsend of lambda * lambda * lambda list
+ | Lsend of meth_kind * lambda * lambda * lambda list
| Levent of lambda * lambda_event
| Lifused of Ident.t * lambda
@@ -225,7 +227,7 @@ let free_variables l =
freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv
| Lassign(id, e) ->
fv := IdentSet.add id !fv; freevars e
- | Lsend (met, obj, args) ->
+ | Lsend (k, met, obj, args) ->
List.iter freevars (met::obj::args)
| Levent (lam, evt) ->
freevars lam
@@ -309,7 +311,8 @@ let subst_lambda s lam =
| Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
| Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
| Lassign(id, e) -> Lassign(id, subst e)
- | Lsend (met, obj, args) -> Lsend (subst met, subst obj, List.map subst args)
+ | Lsend (k, met, obj, args) ->
+ Lsend (k, subst met, subst obj, List.map subst args)
| Levent (lam, evt) -> Levent (subst lam, evt)
| Lifused (v, e) -> Lifused (v, subst e)
and subst_decl (id, exp) = (id, subst exp)
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index f862ca8aa1..2c7c56e01e 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -124,6 +124,8 @@ type let_kind = Strict | Alias | StrictOpt | Variable
we can discard e if x does not appear in e'
Variable: the variable x is assigned later in e' *)
+type meth_kind = Self | Public | Cached
+
type shared_code = (int * int) list (* stack size -> code label *)
type lambda =
@@ -143,7 +145,7 @@ type lambda =
| Lwhile of lambda * lambda
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
| Lassign of Ident.t * lambda
- | Lsend of lambda * lambda * lambda list
+ | Lsend of meth_kind * lambda * lambda * lambda list
| Levent of lambda * lambda_event
| Lifused of Ident.t * lambda
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 3515538bf4..5a1b19e50b 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -376,11 +376,11 @@ let pretty_cases cases =
prerr_string " " ;
prerr_string (Format.flush_str_formatter ()))
ps ;
-(*
+
prerr_string " -> " ;
Printlambda.lambda Format.str_formatter l ;
prerr_string (Format.flush_str_formatter ()) ;
-*)
+
prerr_endline "")
cases
@@ -778,7 +778,7 @@ let rebuild_nexts arg nexts k =
(*
Split a matching.
Splitting is first directed by or-patterns, then by
- must test (e.g. constructors)/variable transitions.
+ tests (e.g. constructors)/variable transitions.
The approach is greedy, every split function attempt to
raise rows as much as possible in the top matrix,
@@ -1778,13 +1778,21 @@ let mk_res get_key env last_choice idef cant_fail ctx =
fail, klist, jumps
-(* Aucune optimisation, reflechir apres la release *)
+(*
+ Following two ``failaction'' function compute n, the trap handler
+ to jump to in case of failure of elementary tests
+*)
+
let mk_failaction_neg partial ctx def = match partial with
| Partial ->
begin match def with
| (_,idef)::_ ->
Some (Lstaticraise (idef,[])),[],jumps_singleton idef ctx
- | _ -> assert false
+ | _ ->
+ (* Act as Total, this means
+ If no appropriate default matrix exists,
+ then this switch cannot fail *)
+ None, [], jumps_empty
end
| Total ->
None, [], jumps_empty
@@ -2284,7 +2292,7 @@ and do_compile_matching_pr repr partial ctx arg x =
prerr_string "COMPILE: " ;
prerr_endline (match partial with Partial -> "Partial" | Total -> "Total") ;
prerr_endline "MATCH" ;
- pretty_ext x ;
+ pretty_precompiled x ;
prerr_endline "CTX" ;
pretty_ctx ctx ;
let (_, jumps) as r = do_compile_matching repr partial ctx arg x in
diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
index 763f8fe03a..acbcd6ff8e 100644
--- a/bytecomp/matching.mli
+++ b/bytecomp/matching.mli
@@ -35,3 +35,7 @@ val for_tupled_function:
exception Cannot_flatten
val flatten_pattern: int -> pattern -> pattern list
+
+val make_test_sequence:
+ lambda option -> primitive -> primitive -> lambda ->
+ (Asttypes.constant * lambda) list -> lambda
diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml
index c4981c95ae..c03523fbcb 100644
--- a/bytecomp/meta.ml
+++ b/bytecomp/meta.ml
@@ -17,6 +17,7 @@ external realloc_global_data : int -> unit = "caml_realloc_global"
external static_alloc : int -> string = "caml_static_alloc"
external static_free : string -> unit = "caml_static_free"
external static_resize : string -> int -> string = "caml_static_resize"
+external static_release_bytecode : string -> int -> unit = "caml_static_release_bytecode"
type closure = unit -> Obj.t
external reify_bytecode : string -> int -> closure = "caml_reify_bytecode"
external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli
index de21a36168..3de027f19c 100644
--- a/bytecomp/meta.mli
+++ b/bytecomp/meta.mli
@@ -18,6 +18,7 @@ external global_data : unit -> Obj.t array = "caml_get_global_data"
external realloc_global_data : int -> unit = "caml_realloc_global"
external static_alloc : int -> string = "caml_static_alloc"
external static_free : string -> unit = "caml_static_free"
+external static_release_bytecode : string -> int -> unit = "caml_static_release_bytecode"
external static_resize : string -> int -> string = "caml_static_resize"
type closure = unit -> Obj.t
external reify_bytecode : string -> int -> closure = "caml_reify_bytecode"
diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
index 8b2ba1e8ca..a7c859d847 100644
--- a/bytecomp/printinstr.ml
+++ b/bytecomp/printinstr.ml
@@ -96,6 +96,8 @@ let instruction ppf = function
| Kisint -> fprintf ppf "\tisint"
| Kisout -> fprintf ppf "\tisout"
| Kgetmethod -> fprintf ppf "\tgetmethod"
+ | Kgetpubmet n -> fprintf ppf "\tgetpubmet %i" n
+ | Kgetdynmet -> fprintf ppf "\tgetdynmet"
| Kstop -> fprintf ppf "\tstop"
| Kevent ev -> fprintf ppf "\tevent \"%s\" %i" ev.ev_char.Lexing.pos_fname
ev.ev_char.Lexing.pos_cnum
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index b8af27831c..4f66ddada4 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -274,10 +274,12 @@ let rec lam ppf = function
lam hi lam body
| Lassign(id, expr) ->
fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
- | Lsend (met, obj, largs) ->
+ | Lsend (k, met, obj, largs) ->
let args ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
- fprintf ppf "@[<2>(send@ %a@ %a%a)@]" lam obj lam met args largs
+ let kind =
+ if k = Self then "self" else if k = Cached then "cache" else "" in
+ fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
| Levent(expr, ev) ->
let kind =
match ev.lev_kind with
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index add9ef7cca..ee59cab742 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -75,8 +75,8 @@ let rec eliminate_ref id = function
dir, eliminate_ref id e3)
| Lassign(v, e) ->
Lassign(v, eliminate_ref id e)
- | Lsend(m, o, el) ->
- Lsend(eliminate_ref id m, eliminate_ref id o,
+ | Lsend(k, m, o, el) ->
+ Lsend(k, eliminate_ref id m, eliminate_ref id o,
List.map (eliminate_ref id) el)
| Levent(l, ev) ->
Levent(eliminate_ref id l, ev)
@@ -144,7 +144,7 @@ let simplify_exits lam =
(* Lalias-bound variables are never assigned, so don't increase
v's refcount *)
count l
- | Lsend(m, o, ll) -> List.iter count (m::o::ll)
+ | Lsend(k, m, o, ll) -> List.iter count (m::o::ll)
| Levent(l, _) -> count l
| Lifused(v, l) -> count l
@@ -250,7 +250,7 @@ let simplify_exits lam =
| Lfor(v, l1, l2, dir, l3) ->
Lfor(v, simplif l1, simplif l2, dir, simplif l3)
| Lassign(v, l) -> Lassign(v, simplif l)
- | Lsend(m, o, ll) -> Lsend(simplif m, simplif o, List.map simplif ll)
+ | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
| Levent(l, ev) -> Levent(simplif l, ev)
| Lifused(v, l) -> Lifused (v,simplif l)
in
@@ -313,7 +313,7 @@ let simplify_lets lam =
(* Lalias-bound variables are never assigned, so don't increase
v's refcount *)
count l
- | Lsend(m, o, ll) -> List.iter count (m::o::ll)
+ | Lsend(_, m, o, ll) -> List.iter count (m::o::ll)
| Levent(l, _) -> count l
| Lifused(v, l) ->
if count_var v > 0 then count l
@@ -402,7 +402,7 @@ let simplify_lets lam =
| Lfor(v, l1, l2, dir, l3) ->
Lfor(v, simplif l1, simplif l2, dir, simplif l3)
| Lassign(v, l) -> Lassign(v, simplif l)
- | Lsend(m, o, ll) -> Lsend(simplif m, simplif o, List.map simplif ll)
+ | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
| Levent(l, ev) -> Levent(simplif l, ev)
| Lifused(v, l) ->
if count_var v > 0 then simplif l else lambda_unit
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index f0109dae31..59153bd677 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -22,7 +22,7 @@ open Translcore
(* XXX Rajouter des evenements... *)
-type error = Illegal_class_expr
+type error = Illegal_class_expr | Tags of label * label
exception Error of Location.t * error
@@ -103,15 +103,18 @@ let transl_super tbl meths inh_methods rem =
let create_object cl obj init =
let obj' = Ident.create "self" in
- let (inh_init, obj_init) = init obj' in
+ let (inh_init, obj_init, has_init) = init obj' in
if obj_init = lambda_unit then
- (inh_init,
- Lapply (oo_prim "create_object_and_run_initializers", [obj; Lvar cl]))
+ (inh_init,
+ Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
+ else"create_object_opt"),
+ [obj; Lvar cl]))
else begin
(inh_init,
Llet(Strict, obj',
Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
Lsequence(obj_init,
+ if not has_init then Lvar obj' else
Lapply (oo_prim "run_initializers_opt",
[obj; Lvar obj'; Lvar cl]))))
end
@@ -129,20 +132,23 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
Lapply(Lvar obj_init, env @ [obj]))
| Tclass_structure str ->
create_object cl_table obj (fun obj ->
- let (inh_init, obj_init) =
+ let (inh_init, obj_init, has_init) =
List.fold_right
- (fun field (inh_init, obj_init) ->
+ (fun field (inh_init, obj_init, has_init) ->
match field with
Cf_inher (cl, _, _) ->
let (inh_init, obj_init') =
build_object_init cl_table (Lvar obj) [] inh_init
(fun _ -> lambda_unit) cl
in
- (inh_init, lsequence obj_init' obj_init)
+ (inh_init, lsequence obj_init' obj_init, true)
| Cf_val (_, id, exp) ->
- (inh_init, lsequence (set_inst_var obj id exp) obj_init)
- | Cf_meth _ | Cf_init _ ->
- (inh_init, obj_init)
+ (inh_init, lsequence (set_inst_var obj id exp) obj_init,
+ has_init)
+ | Cf_meth _ ->
+ (inh_init, obj_init, has_init)
+ | Cf_init _ ->
+ (inh_init, obj_init, true)
| Cf_let (rec_flag, defs, vals) ->
(inh_init,
Translcore.transl_let rec_flag defs
@@ -150,15 +156,17 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
(fun (id, expr) rem ->
lsequence (Lifused(id, set_inst_var obj id expr))
rem)
- vals obj_init)))
+ vals obj_init),
+ has_init))
str.cl_field
- (inh_init, obj_init obj)
+ (inh_init, obj_init obj, false)
in
(inh_init,
List.fold_right
(fun (id, expr) rem ->
lsequence (Lifused (id, set_inst_var obj id expr)) rem)
- params obj_init))
+ params obj_init,
+ has_init))
| Tclass_fun (pat, vals, cl, partial) ->
let (inh_init, obj_init) =
build_object_init cl_table obj (vals @ params) inh_init obj_init cl
@@ -203,16 +211,24 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
(inh_init, lfunction [env] (subst_env env inh_init obj_init))
-let bind_method tbl public_methods lab id cl_init =
- if List.mem lab public_methods then
- Llet(Alias, id, Lvar (meth lab), cl_init)
- else
- Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
- [Lvar tbl; transl_label lab]),
- cl_init)
-
-let bind_methods tbl public_methods meths cl_init =
- Meths.fold (bind_method tbl public_methods) meths cl_init
+let bind_method tbl lab id cl_init =
+ Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
+ [Lvar tbl; transl_label lab]),
+ cl_init)
+
+let bind_methods tbl meths cl_init =
+ let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
+ let len = List.length methl in
+ if len < 2 then Meths.fold (bind_method tbl) meths cl_init else
+ let ids = Ident.create "ids" in
+ let i = ref len in
+ Llet(StrictOpt, ids,
+ Lapply (oo_prim "get_method_labels",
+ [Lvar tbl; transl_meth_list (List.map fst methl)]),
+ List.fold_right
+ (fun (lab,id) lam ->
+ decr i; Llet(StrictOpt, id, Lprim(Pfield !i, [Lvar ids]), lam))
+ methl cl_init)
let output_methods tbl vals methods lam =
let lam =
@@ -233,7 +249,7 @@ let rec ignore_cstrs cl =
| Tclass_apply (cl, _) -> ignore_cstrs cl
| _ -> cl
-let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
+let rec build_class_init cla cstr inh_init cl_init msubst top cl =
match cl.cl_desc with
Tclass_ident path ->
begin match inh_init with
@@ -255,7 +271,7 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
Cf_inher (cl, vals, meths) ->
let cl_init = output_methods cla values methods cl_init in
let inh_init, cl_init =
- build_class_init cla pub_meths false inh_init
+ build_class_init cla false inh_init
(transl_vals cla false false vals
(transl_super cla str.cl_meths meths cl_init))
msubst top cl in
@@ -296,18 +312,18 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
(inh_init, cl_init, [], [])
in
let cl_init = output_methods cla values methods cl_init in
- (inh_init, bind_methods cla pub_meths str.cl_meths cl_init)
+ (inh_init, bind_methods cla str.cl_meths cl_init)
| Tclass_fun (pat, vals, cl, _) ->
let (inh_init, cl_init) =
- build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
+ build_class_init cla cstr inh_init cl_init msubst top cl
in
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
(inh_init, transl_vals cla true false vals cl_init)
| Tclass_apply (cl, exprs) ->
- build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
+ build_class_init cla cstr inh_init cl_init msubst top cl
| Tclass_let (rec_flag, defs, vals, cl) ->
let (inh_init, cl_init) =
- build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
+ build_class_init cla cstr inh_init cl_init msubst top cl
in
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
(inh_init, transl_vals cla true false vals cl_init)
@@ -331,7 +347,7 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
cl_init))
| _ ->
let core cl_init =
- build_class_init cla pub_meths true inh_init cl_init msubst top cl
+ build_class_init cla true inh_init cl_init msubst top cl
in
if cstr then core cl_init else
let (inh_init, cl_init) =
@@ -455,8 +471,8 @@ let rec builtin_meths self env env2 body =
"var", [Lvar n]
| Lprim(Pfield n, [Lvar e]) when Ident.same e env ->
"env", [Lvar env2; Lconst(Const_pointer n)]
- | Lsend(Lvar n, Lvar s, []) when List.mem s self ->
- "meth", [Lvar n]
+ | Lsend(Self, met, Lvar s, []) when List.mem s self ->
+ "meth", [met]
| _ -> raise Not_found
in
match body with
@@ -470,9 +486,17 @@ let rec builtin_meths self env env2 body =
| Lapply(f, [p; arg]) when const_path f && const_path p ->
let s, args = conv arg in
("app_const_"^s, f :: p :: args)
- | Lsend(Lvar n, Lvar s, [arg]) when List.mem s self ->
+ | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self ->
let s, args = conv arg in
("meth_app_"^s, Lvar n :: args)
+ | Lsend(Self, met, Lvar s, []) when List.mem s self ->
+ ("get_meth", [met])
+ | Lsend(Public, met, arg, []) ->
+ let s, args = conv arg in
+ ("send_"^s, met :: args)
+ | Lsend(Cached, met, arg, [_;_]) ->
+ let s, args = conv arg in
+ ("send_"^s, met :: args)
| Lfunction (Curried, [x], body) ->
let rec enter self = function
| Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
@@ -512,6 +536,10 @@ module M = struct
| "meth_app_var" -> MethAppVar
| "meth_app_env" -> MethAppEnv
| "meth_app_meth" -> MethAppMeth
+ | "send_const" -> SendConst
+ | "send_var" -> SendVar
+ | "send_env" -> SendEnv
+ | "send_meth" -> SendMeth
| _ -> assert false
in Lconst(Const_pointer(Obj.magic tag)) :: args
end
@@ -604,14 +632,24 @@ let transl_class ids cl_id arity pub_meths cl =
if not (Translcore.check_recursive_lambda ids obj_init) then
raise(Error(cl.cl_loc, Illegal_class_expr));
let (inh_init', cl_init) =
- build_class_init cla pub_meths true (List.rev inh_init)
- obj_init msubst top cl
+ build_class_init cla true (List.rev inh_init) obj_init msubst top cl
in
assert (inh_init' = []);
let table = Ident.create "table"
- and class_init = Ident.create "class_init"
+ and class_init = Ident.create (Ident.name cl_id ^ "_init")
and env_init = Ident.create "env_init"
and obj_init = Ident.create "obj_init" in
+ let pub_meths =
+ List.sort
+ (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
+ pub_meths in
+ let tags = List.map Btype.hash_variant pub_meths in
+ let rev_map = List.combine tags pub_meths in
+ List.iter2
+ (fun tag name ->
+ let name' = List.assoc tag rev_map in
+ if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
+ tags pub_meths;
let ltable table lam =
Llet(Strict, table,
Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
@@ -747,3 +785,6 @@ open Format
let report_error ppf = function
| Illegal_class_expr ->
fprintf ppf "This kind of class expression is not allowed"
+ | Tags (lab1, lab2) ->
+ fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s"
+ lab1 lab2 "Change one of them."
diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli
index a17a0b1178..85d5f74bcd 100644
--- a/bytecomp/translclass.mli
+++ b/bytecomp/translclass.mli
@@ -19,7 +19,7 @@ val dummy_class : lambda -> lambda
val transl_class :
Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
-type error = Illegal_class_expr
+type error = Illegal_class_expr | Tags of string * string
exception Error of Location.t * error
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 857ac43879..eab9235b0a 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -573,9 +573,16 @@ let rec transl_exp e =
and transl_exp0 e =
match e.exp_desc with
Texp_ident(path, {val_kind = Val_prim p}) ->
- if p.prim_name = "%send" then
+ let public_send = p.prim_name = "%send" in
+ if public_send || p.prim_name = "%sendself" then
+ let kind = if public_send then Public else Self in
let obj = Ident.create "obj" and meth = Ident.create "meth" in
- Lfunction(Curried, [obj; meth], Lsend(Lvar meth, Lvar obj, []))
+ Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, []))
+ else if p.prim_name = "%sendcache" then
+ let obj = Ident.create "obj" and meth = Ident.create "meth" in
+ let cache = Ident.create "cache" and pos = Ident.create "pos" in
+ Lfunction(Curried, [obj; meth; cache; pos],
+ Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos]))
else
transl_primitive p
| Texp_ident(path, {val_kind = Val_anc _}) ->
@@ -619,17 +626,26 @@ and transl_exp0 e =
when List.length args = p.prim_arity
&& List.for_all (fun (arg,_) -> arg <> None) args ->
let args = List.map (function Some x, _ -> x | _ -> assert false) args in
- if p.prim_name = "%send" then
- let obj = transl_exp (List.hd args) in
- event_after e (Lsend (transl_exp (List.nth args 1), obj, []))
- else let prim = transl_prim p args in
- begin match (prim, args) with
- (Praise, [arg1]) ->
- Lprim(Praise, [event_after arg1 (transl_exp arg1)])
- | (_, _) ->
- if primitive_is_ccall prim
- then event_after e (Lprim(prim, transl_list args))
- else Lprim(prim, transl_list args)
+ let argl = transl_list args in
+ let public_send = p.prim_name = "%send"
+ || not !Clflags.native_code && p.prim_name = "%sendcache"in
+ if public_send || p.prim_name = "%sendself" then
+ let kind = if public_send then Public else Self in
+ let obj = List.hd argl in
+ event_after e (Lsend (kind, List.nth argl 1, obj, []))
+ else if p.prim_name = "%sendcache" then
+ match argl with [obj; meth; cache; pos] ->
+ event_after e (Lsend(Cached, meth, obj, [cache; pos]))
+ | _ -> assert false
+ else begin
+ let prim = transl_prim p args in
+ match (prim, args) with
+ (Praise, [arg1]) ->
+ Lprim(Praise, [event_after arg1 (List.hd argl)])
+ | (_, _) ->
+ if primitive_is_ccall prim
+ then event_after e (Lprim(prim, argl))
+ else Lprim(prim, argl)
end
| Texp_apply(funct, oargs) ->
event_after e (transl_apply (transl_exp funct) oargs)
@@ -698,7 +714,7 @@ and transl_exp0 e =
let ll = transl_list expr_list in
begin try
(* Deactivate constant optimization if array is small enough *)
- if List.length ll <= 5 then raise Not_constant;
+ if List.length ll <= 4 then raise Not_constant;
let cl = List.map extract_constant ll in
let master =
match kind with
@@ -707,7 +723,7 @@ and transl_exp0 e =
| Pfloatarray ->
Lconst(Const_float_array(List.map extract_float cl))
| Pgenarray ->
- assert false in
+ raise Not_constant in (* can this really happen? *)
Lprim(Pccall prim_obj_dup, [master])
with Not_constant ->
Lprim(Pmakearray kind, ll)
@@ -732,12 +748,16 @@ and transl_exp0 e =
(Lifthenelse(transl_exp cond, event_before body (transl_exp body),
staticfail))
| Texp_send(expr, met) ->
- let met_id =
- match met with
- Tmeth_name nm -> Translobj.meth nm
- | Tmeth_val id -> id
+ let obj = transl_exp expr in
+ let lam =
+ match met with
+ Tmeth_val id -> Lsend (Self, Lvar id, obj, [])
+ | Tmeth_name nm ->
+ let (tag, cache) = Translobj.meth obj nm in
+ let kind = if cache = [] then Public else Cached in
+ Lsend (kind, tag, obj, cache)
in
- event_after e (Lsend(Lvar met_id, transl_exp expr, []))
+ event_after e lam
| Texp_new (cl, _) ->
Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit])
| Texp_instvar(path_self, path) ->
@@ -800,10 +820,10 @@ and transl_tupled_cases patl_expr_list =
and transl_apply lam sargs =
let lapply funct args =
match funct with
- Lsend(lmet, lobj, largs) ->
- Lsend(lmet, lobj, largs @ args)
- | Levent(Lsend(lmet, lobj, largs), _) ->
- Lsend(lmet, lobj, largs @ args)
+ Lsend(k, lmet, lobj, largs) ->
+ Lsend(k, lmet, lobj, largs @ args)
+ | Levent(Lsend(k, lmet, lobj, largs), _) ->
+ Lsend(k, lmet, lobj, largs @ args)
| Lapply(lexp, largs) ->
Lapply(lexp, largs @ args)
| lexp ->
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index e2afb162ba..2da6af3926 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -138,21 +138,21 @@ let init_value modl =
[Lvar undef_function_id])
| _ -> raise Not_found in
init_v :: init_value_struct env rem
- | Tsig_type(id, tdecl) :: rem ->
+ | Tsig_type(id, tdecl, _) :: rem ->
init_value_struct (Env.add_type id tdecl env) rem
| Tsig_exception(id, edecl) :: rem ->
transl_exception
id (Some Predef.path_undefined_recursive_module) edecl ::
init_value_struct env rem
- | Tsig_module(id, mty) :: rem ->
+ | Tsig_module(id, mty, _) :: rem ->
init_value_mod env mty ::
init_value_struct (Env.add_module id mty env) rem
| Tsig_modtype(id, minfo) :: rem ->
init_value_struct (Env.add_modtype id minfo env) rem
- | Tsig_class(id, cdecl) :: rem ->
+ | Tsig_class(id, cdecl, _) :: rem ->
Translclass.dummy_class (Lvar undef_function_id) ::
init_value_struct env rem
- | Tsig_cltype(id, ctyp) :: rem ->
+ | Tsig_cltype(id, ctyp, _) :: rem ->
init_value_struct env rem
in
try
@@ -550,7 +550,9 @@ let transl_store_implementation module_name (str, restr) =
primitive_declarations := [];
let module_id = Ident.create_persistent module_name in
let (map, prims, size) = build_ident_map restr (defined_idents str) in
- (size, transl_label_init (transl_store_structure module_id map prims str))
+ transl_store_label_init module_id size
+ (transl_store_structure module_id map prims) str
+ (*size, transl_label_init (transl_store_structure module_id map prims str)*)
(* Compile a toplevel phrase *)
@@ -654,15 +656,19 @@ let transl_toplevel_definition str =
(* Compile the initialization code for a packed library *)
+let get_component = function
+ None -> Lconst const_unit
+ | Some id -> Lprim(Pgetglobal id, [])
+
let transl_package component_names target_name coercion =
let components =
match coercion with
Tcoerce_none ->
- List.map (fun id -> Lprim(Pgetglobal id, [])) component_names
+ List.map get_component component_names
| Tcoerce_structure pos_cc_list ->
let g = Array.of_list component_names in
List.map
- (fun (pos, cc) -> apply_coercion cc (Lprim(Pgetglobal g.(pos), [])))
+ (fun (pos, cc) -> apply_coercion cc (get_component g.(pos)))
pos_cc_list
| _ ->
assert false in
@@ -680,7 +686,7 @@ let transl_store_package component_names target_name coercion =
(fun pos id ->
Lprim(Psetfield(pos, false),
[Lprim(Pgetglobal target_name, []);
- Lprim(Pgetglobal id, [])]))
+ get_component id]))
0 component_names)
| Tcoerce_structure pos_cc_list ->
let id = Array.of_list component_names in
@@ -689,7 +695,7 @@ let transl_store_package component_names target_name coercion =
(fun dst (src, cc) ->
Lprim(Psetfield(dst, false),
[Lprim(Pgetglobal target_name, []);
- apply_coercion cc (Lprim(Pgetglobal id.(src), []))]))
+ apply_coercion cc (get_component id.(src))]))
0 pos_cc_list)
| _ -> assert false
diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
index 14ef3bb926..7a2aa5a0f2 100644
--- a/bytecomp/translmod.mli
+++ b/bytecomp/translmod.mli
@@ -22,9 +22,10 @@ val transl_implementation: string -> structure * module_coercion -> lambda
val transl_store_implementation:
string -> structure * module_coercion -> int * lambda
val transl_toplevel_definition: structure -> lambda
-val transl_package: Ident.t list -> Ident.t -> module_coercion -> lambda
+val transl_package:
+ Ident.t option list -> Ident.t -> module_coercion -> lambda
val transl_store_package:
- Ident.t list -> Ident.t -> module_coercion -> int * lambda
+ Ident.t option list -> Ident.t -> module_coercion -> int * lambda
val toplevel_name: Ident.t -> string
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index ea449202eb..9899e44b3e 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -13,6 +13,7 @@
(* $Id$ *)
open Misc
+open Primitive
open Asttypes
open Longident
open Lambda
@@ -44,23 +45,55 @@ let share c =
(* Collect labels *)
-let used_methods = ref ([] : (string * Ident.t) list);;
-
-let meth lab =
+let cache_required = ref false
+let method_cache = ref lambda_unit
+let method_count = ref 0
+let method_table = ref []
+
+let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s)))
+
+let next_cache tag =
+ let n = !method_count in
+ incr method_count;
+ (tag, [!method_cache; Lconst(Const_base(Const_int n))])
+
+let rec is_path = function
+ Lvar _ | Lprim (Pgetglobal _, []) | Lconst _ -> true
+ | Lprim (Pfield _, [lam]) -> is_path lam
+ | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2]) ->
+ is_path lam1 && is_path lam2
+ | _ -> false
+
+let meth obj lab =
+ let tag = meth_tag lab in
+ if not (!cache_required && !Clflags.native_code) then (tag, []) else
+ if not (is_path obj) then next_cache tag else
try
- List.assoc lab !used_methods
+ let r = List.assoc obj !method_table in
+ try
+ (tag, List.assoc tag !r)
+ with Not_found ->
+ let p = next_cache tag in
+ r := p :: !r;
+ p
with Not_found ->
- let id = Ident.create lab in
- used_methods := (lab, id)::!used_methods;
- id
+ let p = next_cache tag in
+ method_table := (obj, ref [p]) :: !method_table;
+ p
let reset_labels () =
Hashtbl.clear consts;
- used_methods := []
+ method_count := 0;
+ method_table := []
(* Insert labels *)
let string s = Lconst (Const_base (Const_string s))
+let int n = Lconst (Const_base (Const_int n))
+
+let prim_makearray =
+ { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true;
+ prim_native_name = ""; prim_native_float = false }
let transl_label_init expr =
let expr =
@@ -68,39 +101,41 @@ let transl_label_init expr =
(fun c id expr -> Llet(Alias, id, Lconst c, expr))
consts expr
in
- let expr =
- if !used_methods = [] then expr else
- let init = Ident.create "new_method" in
- Llet(StrictOpt, init, oo_prim "new_method",
- List.fold_right
- (fun (lab, id) expr ->
- Llet(StrictOpt, id, Lapply(Lvar init, [string lab]), expr))
- !used_methods
- expr)
- in
reset_labels ();
expr
+let transl_store_label_init glob size f arg =
+ method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]);
+ let expr = f arg in
+ let (size, expr) =
+ if !method_count = 0 then (size, expr) else
+ (size+1,
+ Lsequence(
+ Lprim(Psetfield(size, false),
+ [Lprim(Pgetglobal glob, []);
+ Lprim (Pccall prim_makearray, [int !method_count; int 0])]),
+ expr))
+ in
+ (size, transl_label_init expr)
(* Share classes *)
let wrapping = ref false
-let required = ref true
let top_env = ref Env.empty
let classes = ref []
let oo_add_class id =
classes := id :: !classes;
- (!top_env, !required)
+ (!top_env, !cache_required)
let oo_wrap env req f x =
if !wrapping then
- if !required then f x else
- try required := true; let lam = f x in required := false; lam
- with exn -> required := false; raise exn
+ if !cache_required then f x else
+ try cache_required := true; let lam = f x in cache_required := false; lam
+ with exn -> cache_required := false; raise exn
else try
wrapping := true;
- required := req;
+ cache_required := req;
top_env := env;
classes := [];
let lambda = f x in
diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli
index f0a92b3324..d6e432da5c 100644
--- a/bytecomp/translobj.mli
+++ b/bytecomp/translobj.mli
@@ -17,10 +17,12 @@ open Lambda
val oo_prim: string -> lambda
val share: structured_constant -> lambda
-val meth: string -> Ident.t
+val meth: lambda -> string -> lambda * lambda list
val reset_labels: unit -> unit
val transl_label_init: lambda -> lambda
+val transl_store_label_init:
+ Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
val oo_add_class: Ident.t -> Env.t * bool
diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
index c931519ee4..8838145468 100644
--- a/bytecomp/typeopt.ml
+++ b/bytecomp/typeopt.ml
@@ -87,7 +87,8 @@ let array_element_kind env ty =
let array_kind_gen ty env =
let array_ty = Ctype.expand_head env (Ctype.correct_levels ty) in
match (Ctype.repr array_ty).desc with
- Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array ->
+ Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
+ when Path.same p Predef.path_array ->
array_element_kind env elt_ty
| _ ->
(* This can happen with e.g. Obj.field *)
View Lorry Controller Status