diff options
Diffstat (limited to 'bytecomp')
| -rw-r--r-- | bytecomp/bytepackager.ml | 55 | ||||
| -rw-r--r-- | bytecomp/emitcode.ml | 10 | ||||
| -rw-r--r-- | bytecomp/emitcode.mli | 9 | ||||
| -rw-r--r-- | bytecomp/matching.ml | 195 | ||||
| -rw-r--r-- | bytecomp/printlambda.ml | 12 | ||||
| -rw-r--r-- | bytecomp/symtable.ml | 5 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 88 | ||||
| -rw-r--r-- | bytecomp/translmod.ml | 55 | ||||
| -rw-r--r-- | bytecomp/translmod.mli | 4 | ||||
| -rw-r--r-- | bytecomp/typeopt.ml | 3 |
10 files changed, 271 insertions, 165 deletions
diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index cf33545ad4..450321ac76 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -17,7 +17,6 @@ open Misc open Instruct -open Opcodes open Emitcode type error = @@ -130,40 +129,21 @@ let rec rename_append_bytecode_list oc mapping defined ofs = function oc mapping (Ident.create_persistent compunit.cu_name :: defined) (ofs + size) rem -(* Generate the code that builds the tuple representing the package - module: - GETGLOBAL M.An - PUSHGETGLOBAL M.An-1 - ... - PUSHGETGLOBAL M.A1 - MAKEBLOCK tag = 0 size = n - SETGLOBAL M -*) - -let build_global_target oc target_name mapping ofs = - let out_word n = - output_byte oc n; - output_byte oc (n lsr 8); - output_byte oc (n lsr 16); - output_byte oc (n lsr 24) in - let rec build_global first pos = function - [] -> - out_word opMAKEBLOCK; (* pos *) - out_word (List.length mapping); (* pos + 4 *) - out_word 0; (* pos + 8 *) - out_word opSETGLOBAL; (* pos + 12 *) - out_word 0; (* pos + 16 *) - relocs := (Reloc_setglobal target_name, pos + 16) :: !relocs - | (oldname, newname) :: rem -> - out_word (if first then opGETGLOBAL else opPUSHGETGLOBAL); (* pos *) - out_word 0; (* pos + 4 *) - relocs := (Reloc_getglobal newname, pos + 4) :: !relocs; - build_global false (pos + 8) rem in - build_global true ofs (List.rev mapping) +(* Generate the code that builds the tuple representing the package module *) + +let build_global_target oc target_name mapping pos coercion = + let lam = + Translmod.transl_package (List.map snd mapping) + (Ident.create_persistent target_name) coercion in + let instrs = + Bytegen.compile_implementation target_name lam in + let rel = + Emitcode.to_packed_file oc instrs in + relocs := List.map (fun (r, ofs) -> (r, pos + ofs)) rel @ !relocs (* Build the .cmo file obtained by packaging the given .cmo files. *) -let package_object_files objfiles targetfile targetname = +let package_object_files objfiles targetfile targetname coercion = let units = List.map (fun f -> (f, read_unit_info f)) objfiles in let unit_names = @@ -181,9 +161,10 @@ let package_object_files objfiles targetfile targetname = 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 (Ident.create_persistent targetname) mapping ofs; + build_global_target oc targetname mapping ofs coercion; let pos_debug = pos_out oc in - if !Clflags.debug && !events <> [] then output_value oc (List.rev !events); + if !Clflags.debug && !events <> [] then + output_value oc (List.rev !events); let pos_final = pos_out oc in let imports = List.filter @@ -220,10 +201,10 @@ let package_files files targetfile = let targetcmi = prefix ^ ".cmi" in let targetname = String.capitalize(Filename.basename prefix) in try - Typemod.package_units objfiles targetcmi targetname; - package_object_files objfiles targetfile targetname + let coercion = Typemod.package_units objfiles targetcmi targetname in + package_object_files objfiles targetfile targetname coercion with x -> - remove_file targetcmi; remove_file targetfile; raise x + remove_file targetfile; raise x (* Error report *) diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 4613241fcf..a2ee15a820 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -425,3 +425,13 @@ let to_memory init_code fun_code = and code_size = !out_position in init(); (code, code_size, reloc) + +(* Emission to a file for a packed library *) + +let to_packed_file outchan code = + init(); + emit code; + output outchan !out_buffer 0 !out_position; + let reloc = !reloc_info in + init(); + reloc diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index 481ad506b1..226f869971 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -42,6 +42,7 @@ type compilation_unit = magic number (Config.cmo_magic_number) absolute offset of compilation unit descriptor block of relocatable bytecode + debugging information if any compilation unit descriptor *) (* Descriptor for libraries *) @@ -75,4 +76,10 @@ val to_memory: instruction list -> instruction list -> block of relocatable bytecode size of this block relocation information *) - +val to_packed_file: + out_channel -> instruction list -> (reloc_info * int) list + (* Arguments: + channel on output file + list of instructions to emit + Result: + relocation information (reversed) *) diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index ea492d30c4..c9b1d101a2 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -929,22 +929,23 @@ let make_default matcher (exit,l) = exit,make_rec l (* Then come various functions, - There is one set of functions per match style - (constants, constructors etc. + There is one set of functions per matching style + (constants, constructors etc.) - - matcher function are arguments to make_default (for defaukt handlers) - They may raise NoMatch or OrPat and perform the full - matching (selection + arguments). + - matcher function are arguments to make_default (for defaukt handlers) + They may raise NoMatch or OrPat and perform the full + matching (selection + arguments). - - - get_args and get_key are for the compiled matrices, note that - selection and geting arguments are separed. + + - get_args and get_key are for the compiled matrices, note that + selection and geting arguments are separed. - - make_*_matching combines the previous functions for produicing - new ``pattern_matching'' records. + - make_ _matching combines the previous functions for produicing + new ``pattern_matching'' records. *) + let rec matcher_const cst p rem = match p.pat_desc with | Tpat_or (p1,p2,_) -> begin try @@ -960,7 +961,6 @@ let get_key_constant caller = function | p -> prerr_endline ("BAD: "^caller) ; pretty_pat p ; - assert false let get_args_constant _ rem = rem @@ -974,8 +974,8 @@ let make_constant_matching p def ctx = function and ctx = filter_ctx p ctx in {pm = {cases = []; args = argl ; default = def} ; - ctx = ctx ; - pat = normalize_pat p} + ctx = ctx ; + pat = normalize_pat p} @@ -1001,8 +1001,8 @@ let get_key_constr = function | _ -> assert false let get_args_constr p rem = match p with - | {pat_desc=Tpat_construct (_,args)} -> args @ rem - | _ -> assert false +| {pat_desc=Tpat_construct (_,args)} -> args @ rem +| _ -> assert false let pat_as_constr = function | {pat_desc=Tpat_construct (cstr,_)} -> cstr @@ -1035,8 +1035,8 @@ let matcher_constr cstr = match cstr.cstr_arity with | None, Some r2 -> r2 | Some (a1::rem1), Some (a2::_) -> {a1 with - pat_loc = Location.none ; - pat_desc = Tpat_or (a1, a2, None)}:: +pat_loc = Location.none ; +pat_desc = Tpat_or (a1, a2, None)}:: rem | _, _ -> assert false end @@ -1066,8 +1066,8 @@ let make_constr_matching p def ctx = function {pm= {cases = []; args = newargs; default = make_default (matcher_constr cstr) def} ; - ctx = filter_ctx p ctx ; - pat=normalize_pat p} + ctx = filter_ctx p ctx ; + pat=normalize_pat p} let divide_constructor ctx pm = @@ -1090,15 +1090,15 @@ let rec matcher_variant_const lab p rem = match p.pat_desc with | Tpat_any -> rem | _ -> raise NoMatch - + let make_variant_matching_constant p lab def ctx = function [] -> fatal_error "Matching.make_variant_matching_constant" | ((arg, mut) :: argl) -> let def = make_default (matcher_variant_const lab) def and ctx = filter_ctx p ctx in {pm={ cases = []; args = argl ; default=def} ; - ctx=ctx ; - pat = normalize_pat p} + ctx=ctx ; + pat = normalize_pat p} let matcher_variant_nonconst lab p rem = match p.pat_desc with | Tpat_or (_,_,_) -> raise OrPat @@ -1129,7 +1129,7 @@ let divide_variant row ctx ({cases = cl; args = al; default=def} as pm) = ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem -> let variants = divide rem in if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent - with Not_found -> true + with Not_found -> true then variants else begin @@ -1137,10 +1137,10 @@ let divide_variant row ctx ({cases = cl; args = al; default=def} as pm) = match pato with None -> add (make_variant_matching_constant p lab def ctx) variants - (Cstr_constant tag) (patl, action) al + (Cstr_constant tag) (patl, action) al | Some pat -> add (make_variant_matching_nonconst p lab def ctx) variants - (Cstr_block tag) (pat :: patl, action) al + (Cstr_block tag) (pat :: patl, action) al end | cl -> [] in @@ -1148,7 +1148,7 @@ let divide_variant row ctx ({cases = cl; args = al; default=def} as pm) = (* Three ``no-test'' cases -*) + *) (* Matching against a variable *) @@ -1169,16 +1169,16 @@ let divide_var ctx pm = let get_args_tuple arity p rem = match p with - | {pat_desc = Tpat_any} -> omegas arity @ rem - | {pat_desc = Tpat_tuple args} -> - args @ rem - | _ -> assert false +| {pat_desc = Tpat_any} -> omegas arity @ rem +| {pat_desc = Tpat_tuple args} -> + args @ rem +| _ -> assert false let matcher_tuple arity p rem = match p.pat_desc with | Tpat_or (_,_,_) -> raise OrPat | Tpat_var _ -> get_args_tuple arity omega rem | _ -> get_args_tuple arity p rem - + let make_tuple_matching arity def = function [] -> fatal_error "Matching.make_tuple_matching" | (arg, mut) :: argl -> @@ -1252,8 +1252,8 @@ let get_key_array = function | _ -> assert false let get_args_array p rem = match p with - | {pat_desc=Tpat_array patl} -> patl@rem - | _ -> assert false +| {pat_desc=Tpat_array patl} -> patl@rem +| _ -> assert false let matcher_array len p rem = match p.pat_desc with | Tpat_or (_,_,_) -> raise OrPat @@ -1273,27 +1273,32 @@ let make_array_matching kind p def ctx = function let def = make_default (matcher_array len) def and ctx = filter_ctx p ctx in {pm={cases = []; args = make_args 0 ; default = def} ; - ctx=ctx ; - pat = normalize_pat p} + ctx=ctx ; + pat = normalize_pat p} let divide_array kind ctx pm = divide (make_array_matching kind) get_key_array get_args_array ctx pm - + (* To combine sub-matchings together *) +let float_compare s1 s2 = + let f1 = float_of_string s1 and f2 = float_of_string s2 in + Pervasives.compare f1 f2 + let sort_lambda_list l = List.sort - (fun (x,_) (y,_) -> Pervasives.compare x y) + (fun (x,_) (y,_) -> match x,y with + | Const_float f1, Const_float f2 -> float_compare f1 f2 + | _, _ -> Pervasives.compare x y) l - let rec cut n l = - if n = 0 then [],l - else match l with - [] -> raise (Invalid_argument "cut") - | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 + if n = 0 then [],l + else match l with + [] -> raise (Invalid_argument "cut") + | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 let rec do_tests_fail fail tst arg = function | [] -> fail @@ -1322,7 +1327,7 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list = and split_sequence const_lambda_list = let list1, list2 = - cut (List.length const_lambda_list / 2) const_lambda_list in + cut (List.length const_lambda_list / 2) const_lambda_list in Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]), make_test_sequence list1, make_test_sequence list2) in make_test_sequence (sort_lambda_list const_lambda_list) @@ -1334,8 +1339,8 @@ let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg]) let prim_string_notequal = Pccall{prim_name = "string_notequal"; - prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false} + prim_arity = 2; prim_alloc = false; + prim_native_name = ""; prim_native_float = false} let rec explode_inter offset i j act k = if i <= j then @@ -1384,8 +1389,8 @@ let make_switch_offset arg min_key max_key int_lambda_list default = let offsetarg = make_offset (-min_key) arg in Lswitch(offsetarg, {sw_numconsts = numcases; sw_consts = cases; - sw_numblocks = 0; sw_blocks = []; - sw_failaction = default}) + sw_numblocks = 0; sw_blocks = []; + sw_failaction = default}) let make_switch_switcher arg cases acts = let l = ref [] in @@ -1394,20 +1399,20 @@ let make_switch_switcher arg cases acts = done ; Lswitch(arg, {sw_numconsts = Array.length cases ; sw_consts = !l ; - sw_numblocks = 0 ; sw_blocks = [] ; - sw_failaction = None}) - + sw_numblocks = 0 ; sw_blocks = [] ; + sw_failaction = None}) + let full sw = List.length sw.sw_consts = sw.sw_numconsts && List.length sw.sw_blocks = sw.sw_numblocks - + let make_switch (arg,sw) = match sw.sw_failaction with | None -> let t = Hashtbl.create 17 in let seen l = match l with | Lstaticraise (i,[]) -> - let old = try Hashtbl.find t i with Not_found -> 0 in - Hashtbl.replace t i (old+1) + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old+1) | _ -> () in List.iter (fun (_,lam) -> seen lam) sw.sw_consts ; List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ; @@ -1426,14 +1431,14 @@ let make_switch (arg,sw) = match sw.sw_failaction with | (_,Lstaticraise (j,[]))::rem when j=default -> remove rem | x::rem -> x::remove rem in - Lswitch + Lswitch (arg, {sw with - sw_consts = remove sw.sw_consts ; - sw_blocks = remove sw.sw_blocks ; - sw_failaction = Some (Lstaticraise (default,[]))}) +sw_consts = remove sw.sw_consts ; +sw_blocks = remove sw.sw_blocks ; +sw_failaction = Some (Lstaticraise (default,[]))}) else - Lswitch (arg,sw) + Lswitch (arg,sw) | _ -> Lswitch (arg,sw) module SArg = struct @@ -1472,15 +1477,15 @@ open Switch let lambda_of_int i = Lconst (Const_base (Const_int i)) let rec last def = function -| [] -> def -| [x,_] -> x -| _::rem -> last def rem + | [] -> def + | [x,_] -> x + | _::rem -> last def rem let get_edges low high l = match l with | [] -> low, high | (x,_)::_ -> x, last high l - + let as_interval_canfail fail low high l = let store = mk_store equal_action in let rec nofail_rec cur_low cur_high cur_act = function @@ -1548,8 +1553,17 @@ let as_interval_nofail l = Array.of_list inters, store.act_get () + +let sort_int_lambda_list l = + List.sort + (fun (i1,_) (i2,_) -> + if i1 < i2 then -1 + else if i2 < i1 then 1 + else 0) + l + let as_interval fail low high l = - let l = sort_lambda_list l in + let l = sort_int_lambda_list l in get_edges low high l, (match fail with | None -> as_interval_nofail l @@ -1643,19 +1657,19 @@ let mk_res get_key env last_choice idef cant_fail ctx = klist,jumps_add i ctx jumps) env ([],jumps_fail) in fail, klist, jumps - + (* Aucune optimisation, reflechir apres la release *) let mk_failaction_neg partial ctx (_,def) = match partial with | Partial -> begin match def with - | (_,idef)::_ -> + | (_,idef)::_ -> Some (Lstaticraise (idef,[])),[],jumps_singleton idef ctx - | __ -> assert false - end + | __ -> assert false +end | Total -> None, [], jumps_empty - - + + (* Conforme a l'article et plus simple qu'avant *) and mk_failaction_pos partial seen ctx (_,defs) = let rec scan_def env to_test defs = match to_test,defs with @@ -1682,11 +1696,11 @@ and mk_failaction_pos partial seen ctx (_,defs) = scan_def [] (List.map - (fun pat -> pat, ctx_lub pat ctx) - (complete_pats_constrs seen)) + (fun pat -> pat, ctx_lub pat ctx) + (complete_pats_constrs seen)) defs - + let combine_constant arg cst partial ctx def (const_lambda_list, total, pats) = let fail, to_add, local_jumps = @@ -1715,8 +1729,23 @@ let combine_constant arg cst partial ctx def make_test_sequence fail (Pfloatcomp Cneq) (Pfloatcomp Clt) - arg const_lambda_list in - lambda1,jumps_union local_jumps total + arg const_lambda_list + | Const_int32 _ -> + make_test_sequence + fail + (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt)) + arg const_lambda_list + | Const_int64 _ -> + make_test_sequence + fail + (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt)) + arg const_lambda_list + | Const_nativeint _ -> + make_test_sequence + fail + (Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt)) + arg const_lambda_list + in lambda1,jumps_union local_jumps total @@ -1730,9 +1759,9 @@ let split_cases tag_lambda_list = | Cstr_block n -> (consts, (n, act) :: nonconsts) | _ -> assert false in let const, nonconst = split_rec tag_lambda_list in - sort_lambda_list const, - sort_lambda_list nonconst - + sort_int_lambda_list const, + sort_int_lambda_list nonconst + let combine_constructor arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = @@ -1791,11 +1820,11 @@ let combine_constructor arg ex_pat cstr partial ctx def | (n, _, _, _) -> match same_actions nonconsts with | None -> - make_switch(arg, {sw_numconsts = cstr.cstr_consts; - sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; - sw_blocks = nonconsts; - sw_failaction = None}) + make_switch(arg, {sw_numconsts = cstr.cstr_consts; + sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; + sw_blocks = nonconsts; + sw_failaction = None}) | Some act -> Lifthenelse (Lprim (Pisint, [arg]), @@ -1859,7 +1888,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = make_test_sequence_variant_constant fail arg consts | ([], _) -> let lam = call_switcher_variant_constr - fail arg nonconsts in + fail arg nonconsts in (* One must not dereference integers *) begin match fail with | None -> lam diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 909ee46391..b8af27831c 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -21,12 +21,12 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char c) -> - fprintf ppf "%C" c - | Const_base(Const_string s) -> - fprintf ppf "%S" s - | Const_base(Const_float s) -> - fprintf ppf "%s" s + | Const_base(Const_char c) -> fprintf ppf "%C" c + | Const_base(Const_string s) -> fprintf ppf "%S" s + | Const_base(Const_float f) -> fprintf ppf "%s" f + | Const_base(Const_int32 n) -> fprintf ppf "%lil" n + | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n + | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n | Const_pointer n -> fprintf ppf "%ia" n | Const_block(tag, []) -> fprintf ppf "[%i]" tag diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 74ec833b02..9ea585954d 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -201,7 +201,10 @@ let rec transl_const = function Const_base(Const_int i) -> Obj.repr i | Const_base(Const_char c) -> Obj.repr c | Const_base(Const_string s) -> Obj.repr s - | Const_base(Const_float f) -> Obj.repr(float_of_string f) + | Const_base(Const_float f) -> Obj.repr (float_of_string f) + | Const_base(Const_int32 i) -> Obj.repr i + | Const_base(Const_int64 i) -> Obj.repr i + | Const_base(Const_nativeint i) -> Obj.repr i | Const_pointer i -> Obj.repr i | Const_block(tag, fields) -> let block = Obj.new_block tag (List.length fields) in diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 392a9afe6d..bff8a5dcce 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -65,8 +65,9 @@ let comparisons_table = create_hashtable 11 [ prim_native_name = ""; prim_native_float = false}, Pintcomp Clt, Pfloatcomp Clt, - Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "string_lessthan"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, Pbintcomp(Pnativeint, Clt), Pbintcomp(Pint32, Clt), Pbintcomp(Pint64, Clt)); @@ -75,8 +76,9 @@ let comparisons_table = create_hashtable 11 [ prim_native_name = ""; prim_native_float = false}, Pintcomp Cgt, Pfloatcomp Cgt, - Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "string_greaterthan"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, Pbintcomp(Pnativeint, Cgt), Pbintcomp(Pint32, Cgt), Pbintcomp(Pint64, Cgt)); @@ -85,8 +87,9 @@ let comparisons_table = create_hashtable 11 [ prim_native_name = ""; prim_native_float = false}, Pintcomp Cle, Pfloatcomp Cle, - Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "string_lessequal"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, Pbintcomp(Pnativeint, Cle), Pbintcomp(Pint32, Cle), Pbintcomp(Pint64, Cle)); @@ -95,11 +98,33 @@ let comparisons_table = create_hashtable 11 [ prim_native_name = ""; prim_native_float = false}, Pintcomp Cge, Pfloatcomp Cge, - Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "string_greaterequal"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, Pbintcomp(Pnativeint, Cge), Pbintcomp(Pint32, Cge), - Pbintcomp(Pint64, Cge)) + Pbintcomp(Pint64, Cge)); + "%compare", + (Pccall{prim_name = "compare"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "int_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "float_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "string_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "nativeint_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "int32_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "int64_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}) ] let primitives_table = create_hashtable 57 [ @@ -300,6 +325,8 @@ let transl_primitive p = let check_recursive_lambda idlist lam = let rec check_top idlist = function | Lvar v -> not (List.mem v idlist) + | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> + true | Llet(str, id, arg, body) -> check idlist arg && check_top (add_let id arg idlist) body | Lletrec(bindings, body) -> @@ -313,6 +340,8 @@ let check_recursive_lambda idlist lam = and check idlist = function | Lvar _ -> true | Lfunction(kind, params, body) -> true + | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> + true | Llet(str, id, arg, body) -> check idlist arg && check (add_let id arg idlist) body | Lletrec(bindings, body) -> @@ -339,6 +368,20 @@ let check_recursive_lambda idlist lam = List.fold_right (fun (id, arg) idl -> add_let id arg idl) bindings idlist + (* reverse-engineering the code generated by transl_record case 2 *) + and check_recursive_recordwith idlist = function + | Llet (Strict, id1, Lprim (Pccall prim, [e1]), body) -> + prim = prim_obj_dup && check_top idlist e1 + && check_recordwith_updates idlist id1 body + | _ -> false + + and check_recordwith_updates idlist id1 = function + | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1]), cont) + -> id2 = id1 && check idlist e1 + && check_recordwith_updates idlist id1 cont + | Lvar id2 -> id2 = id1 + | _ -> false + in check_top idlist lam (* To propagate structured constants *) @@ -538,7 +581,8 @@ let rec transl_exp e = end | Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr - | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record" + | Texp_record ([], _) -> + fatal_error "Translcore.transl_exp: bad Texp_record" | Texp_field(arg, lbl) -> let access = match lbl.lbl_repres with @@ -552,27 +596,7 @@ let rec transl_exp e = | Record_float -> Psetfloatfield lbl.lbl_pos in Lprim(access, [transl_exp arg; transl_exp newval]) | Texp_array expr_list -> - let kind = array_kind e in - let len = List.length expr_list in - if len <= Config.max_young_wosize then - Lprim(Pmakearray kind, transl_list expr_list) - else begin - let v = Ident.create "makearray" in - let rec fill_fields pos = function - [] -> - Lvar v - | arg :: rem -> - Lsequence(Lprim(Parraysetu kind, - [Lvar v; - Lconst(Const_base(Const_int pos)); - transl_exp arg]), - fill_fields (pos+1) rem) in - Llet(Strict, v, - Lprim(Pccall prim_makearray, - [Lconst(Const_base(Const_int len)); - transl_exp (List.hd expr_list)]), - fill_fields 1 (List.tl expr_list)) - end + Lprim(Pmakearray (array_kind e), transl_list expr_list) | Texp_ifthenelse(cond, ifso, Some ifnot) -> Lifthenelse(transl_exp cond, event_before ifso (transl_exp ifso), @@ -818,6 +842,8 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = end else begin (* Take a shallow copy of the init record, then mutate the fields of the copy *) + (* If you change anything here, you will likely have to change + [check_recursive_recordwith] in this file. *) let copy_id = Ident.create "newrecord" in let rec update_field (lbl, expr) cont = let upd = diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 99e1e89aec..e49a049d1a 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -378,8 +378,9 @@ let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *) let aliased_idents = ref Ident.empty -let set_toplevel_name id name = - aliased_idents := Ident.add id name !aliased_idents +let set_toplevel_unique_name id = + aliased_idents := + Ident.add id (Ident.unique_toplevel_name id) !aliased_idents let toplevel_name id = try Ident.find_same id !aliased_idents @@ -417,6 +418,9 @@ let transl_toplevel_item = function | Tstr_exn_rebind(id, path) -> toploop_setvalue id (transl_path path) | Tstr_module(id, modl) -> + (* we need to use the unique name for the module because of issues + with "open" (PR#1672) *) + set_toplevel_unique_name id; toploop_setvalue id (transl_module Tcoerce_none (Some(Pident id)) modl) | Tstr_modtype(id, decl) -> @@ -424,10 +428,10 @@ let transl_toplevel_item = function | Tstr_open path -> lambda_unit | Tstr_class cl_list -> + (* we need to use unique names for the classes because there might + be a value named identically *) let ids = List.map (fun (i, _, _, _) -> i) cl_list in - List.iter - (fun id -> set_toplevel_name id (Ident.name id ^ "(c)")) - ids; + List.iter set_toplevel_unique_name ids; Lletrec(List.map (fun (id, arity, meths, cl) -> (id, transl_class ids id arity meths cl)) @@ -453,3 +457,44 @@ let transl_toplevel_item_and_close itm = let transl_toplevel_definition str = reset_labels (); make_sequence transl_toplevel_item_and_close str + +(* Compile the initialization code for a packed library *) + +let transl_package component_names target_name coercion = + let components = + match coercion with + Tcoerce_none -> + List.map (fun id -> Lprim(Pgetglobal id, [])) 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), []))) + pos_cc_list + | _ -> + assert false in + Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) + +let transl_store_package component_names target_name coercion = + let rec make_sequence fn pos arg = + match arg with + [] -> lambda_unit + | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in + match coercion with + Tcoerce_none -> + (List.length component_names, + make_sequence + (fun pos id -> + Lprim(Psetfield(pos, false), + [Lprim(Pgetglobal target_name, []); + Lprim(Pgetglobal id, [])])) + 0 component_names) + | Tcoerce_structure pos_cc_list -> + let id = Array.of_list component_names in + (List.length pos_cc_list, + make_sequence + (fun dst (src, cc) -> + Lprim(Psetfield(dst, false), + [Lprim(Pgetglobal target_name, []); + apply_coercion cc (Lprim(Pgetglobal id.(src), []))])) + 0 pos_cc_list) + | _ -> assert false diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index ffcb0a7ebe..bd9a5dfd96 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -22,6 +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_store_package: + Ident.t list -> Ident.t -> module_coercion -> int * lambda + val toplevel_name: Ident.t -> string val primitive_declarations: string list ref diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index 0dae07a44d..ed019747cf 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -38,7 +38,8 @@ let maybe_pointer exp = not (Path.same p Predef.path_char) && begin try match Env.find_type p exp.exp_env with - {type_kind = Type_variant cstrs} -> + {type_kind = Type_variant []} -> true (* type exn *) + | {type_kind = Type_variant cstrs} -> List.exists (fun (name, args) -> args <> []) cstrs | _ -> true with Not_found -> true |