diff options
Diffstat (limited to 'bytecomp')
34 files changed, 1161 insertions, 576 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 90764de6b..be884ded5 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -146,7 +146,7 @@ let rec size_of_lambda = function begin match kind with | Record_regular | Record_inlined _ -> RHS_block size | Record_float -> RHS_floatblock size - | Record_exception _ -> RHS_block (size + 1) + | Record_extension -> RHS_block (size + 1) end | Llet(str, id, arg, body) -> size_of_lambda body | Lletrec(bindings, body) -> size_of_lambda body @@ -157,7 +157,7 @@ let rec size_of_lambda = function | Lprim (Pmakearray Pgenarray, args) -> assert false | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) -> RHS_block size - | Lprim (Pduprecord (Record_exception _, size), args) -> + | Lprim (Pduprecord (Record_extension, size), args) -> RHS_block (size + 1) | Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size | Levent (lam, _) -> size_of_lambda lam @@ -237,9 +237,15 @@ let add_event ev = (**** Compilation of a lambda expression ****) -(* association staticraise numbers -> (lbl,size of stack *) +let try_blocks = ref [] (* list of stack size for each nested try block *) + +(* association staticraise numbers -> (lbl,size of stack, try_blocks *) let sz_static_raises = ref [] + +let push_static_raise i lbl_handler sz = + sz_static_raises := (i, (lbl_handler, sz, !try_blocks)) :: !sz_static_raises + let find_raise_label i = try List.assoc i !sz_static_raises @@ -251,8 +257,8 @@ let find_raise_label i = (* Will the translation of l lead to a jump to label ? *) let code_as_jump l sz = match l with | Lstaticraise (i,[]) -> - let label,size = find_raise_label i in - if sz = size then + let label,size,tb = find_raise_label i in + if sz = size && tb == !try_blocks then Some label else None @@ -405,10 +411,15 @@ let comp_primitive p args = | Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3) | Pbswap16 -> Kccall("caml_bswap16", 1) | Pbbswap(bi) -> comp_bint_primitive bi "bswap" args + | Pint_as_pointer -> Kccall("caml_int_as_pointer", 1) | _ -> fatal_error "Bytegen.comp_primitive" let is_immed n = immed_min <= n && n <= immed_max +module Storer = + Switch.Store + (struct type t = lambda type key = lambda + let make_key = Lambda.make_key end) (* Compile an expression. The value of the expression is left in the accumulator. @@ -636,8 +647,7 @@ let rec comp_expr env exp sz cont = (comp_expr (add_vars vars (sz+1) env) handler (sz+nvars) (add_pop nvars cont1)) in - sz_static_raises := - (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ; + push_static_raise i lbl_handler (sz+nvars); push_dummies nvars (comp_expr env body (sz+nvars) (add_pop nvars (branch1 :: cont2))) @@ -648,30 +658,39 @@ let rec comp_expr env exp sz cont = (Kpush::comp_expr (add_var var (sz+1) env) handler (sz+1) (add_pop 1 cont1)) in - sz_static_raises := - (i, (lbl_handler, sz)) :: !sz_static_raises ; + push_static_raise i lbl_handler sz; comp_expr env body sz (branch1 :: cont2) end in sz_static_raises := List.tl !sz_static_raises ; r | Lstaticraise (i, args) -> let cont = discard_dead_code cont in - let label,size = find_raise_label i in + let label,size,tb = find_raise_label i in + let cont = branch_to label cont in + let rec loop sz tbb = + if tb == tbb then add_pop (sz-size) cont + else match tbb with + | [] -> assert false + | try_sz :: tbb -> add_pop (sz-try_sz-4) (Kpoptrap :: loop try_sz tbb) + in + let cont = loop sz !try_blocks in begin match args with | [arg] -> (* optim, argument passed in accumulator *) - comp_expr env arg sz - (add_pop (sz-size) (branch_to label cont)) - | _ -> - comp_exit_args env args sz size - (add_pop (sz-size) (branch_to label cont)) + comp_expr env arg sz cont + | _ -> comp_exit_args env args sz size cont end | Ltrywith(body, id, handler) -> let (branch1, cont1) = make_branch cont in let lbl_handler = new_label() in - Kpushtrap lbl_handler :: - comp_expr env body (sz+4) (Kpoptrap :: branch1 :: - Klabel lbl_handler :: Kpush :: - comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1)) + let body_cont = + Kpoptrap :: branch1 :: + Klabel lbl_handler :: Kpush :: + comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1) + in + try_blocks := sz :: !try_blocks; + let l = comp_expr env body (sz+4) body_cont in + try_blocks := List.tl !try_blocks; + Kpushtrap lbl_handler :: l | Lifthenelse(cond, ifso, ifnot) -> comp_binary_test env cond ifso ifnot sz cont | Lsequence(exp1, exp2) -> @@ -699,10 +718,11 @@ let rec comp_expr env exp sz cont = | Lswitch(arg, sw) -> let (branch, cont1) = make_branch cont in let c = ref (discard_dead_code cont1) in + (* Build indirection vectors *) - let store = mk_store Lambda.same in - let act_consts = Array.create sw.sw_numconsts 0 - and act_blocks = Array.create sw.sw_numblocks 0 in + let store = Storer.mk_store () in + let act_consts = Array.make sw.sw_numconsts 0 + and act_blocks = Array.make sw.sw_numblocks 0 in begin match sw.sw_failaction with (* default is index 0 *) | Some fail -> ignore (store.act_store fail) | None -> () @@ -713,7 +733,18 @@ let rec comp_expr env exp sz cont = (fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks; (* Compile and label actions *) let acts = store.act_get () in - let lbls = Array.create (Array.length acts) 0 in +(* + let a = store.act_get_shared () in + Array.iter + (function + | Switch.Shared (Lstaticraise _) -> () + | Switch.Shared act -> + Printlambda.lambda Format.str_formatter act ; + Printf.eprintf "SHARE BYTE:\n%s\n" (Format.flush_str_formatter ()) + | _ -> ()) + a ; +*) + let lbls = Array.make (Array.length acts) 0 in for i = Array.length acts-1 downto 0 do let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in lbls.(i) <- lbl ; @@ -721,11 +752,11 @@ let rec comp_expr env exp sz cont = done ; (* Build label vectors *) - let lbl_blocks = Array.create sw.sw_numblocks 0 in + let lbl_blocks = Array.make sw.sw_numblocks 0 in for i = sw.sw_numblocks - 1 downto 0 do lbl_blocks.(i) <- lbls.(act_blocks.(i)) done; - let lbl_consts = Array.create sw.sw_numconsts 0 in + let lbl_consts = Array.make sw.sw_numconsts 0 in for i = sw.sw_numconsts - 1 downto 0 do lbl_consts.(i) <- lbls.(act_consts.(i)) done; @@ -903,3 +934,10 @@ let compile_phrase expr = let init_code = comp_block empty_env expr 1 [Kreturn 1] in let fun_code = comp_remainder [] in (init_code, fun_code) + +let reset () = + label_counter := 0; + sz_static_raises := []; + compunit_name := ""; + Stack.clear functions_to_compile; + max_stack_used := 0 diff --git a/bytecomp/bytegen.mli b/bytecomp/bytegen.mli index 3c24cc8e8..24f1d64f3 100644 --- a/bytecomp/bytegen.mli +++ b/bytecomp/bytegen.mli @@ -17,3 +17,4 @@ open Instruct val compile_implementation: string -> lambda -> instruction list val compile_phrase: lambda -> instruction list * instruction list +val reset: unit -> unit diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index c63cf80ec..7c96dfd0e 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -60,7 +60,7 @@ let copy_object_file ppf oc name = raise(Error(File_not_found name)) in let ic = open_in_bin file_name in try - let buffer = input_bytes ic (String.length cmo_magic_number) in + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin let compunit_pos = input_binary_int ic in seek_in ic compunit_pos; @@ -124,3 +124,8 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) + +let reset () = + lib_ccobjs := []; + lib_ccopts := []; + lib_dllibs := [] diff --git a/bytecomp/bytelibrarian.mli b/bytecomp/bytelibrarian.mli index 757874cb4..b9a4ced84 100644 --- a/bytecomp/bytelibrarian.mli +++ b/bytecomp/bytelibrarian.mli @@ -30,3 +30,5 @@ exception Error of error open Format val report_error: formatter -> error -> unit + +val reset: unit -> unit diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 75db3533c..c0f8f6a93 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -113,7 +113,7 @@ let scan_file obj_name tolink = raise(Error(File_not_found obj_name)) in let ic = open_in_bin file_name in try - let buffer = input_bytes ic (String.length cmo_magic_number) in + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin (* This is a .cmo file. It must be linked in any case. Read the relocation information to see which modules it @@ -158,15 +158,20 @@ let scan_file obj_name tolink = (* Consistency check between interfaces *) let crc_interfaces = Consistbl.create () +let interfaces = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let check_consistency ppf file_name cu = begin try List.iter - (fun (name, crc) -> - if name = cu.cu_name - then Consistbl.set crc_interfaces name crc file_name - else Consistbl.check crc_interfaces name crc file_name) + (fun (name, crco) -> + interfaces := name :: !interfaces; + match crco with + None -> () + | Some crc -> + if name = cu.cu_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_import(name, user, auth))) @@ -183,7 +188,11 @@ let check_consistency ppf file_name cu = (cu.cu_name, file_name) :: !implementations_defined let extract_crc_interfaces () = - Consistbl.extract crc_interfaces + Consistbl.extract !interfaces crc_interfaces + +let clear_crc_interfaces () = + Consistbl.clear crc_interfaces; + interfaces := [] (* Record compilation events *) @@ -256,7 +265,7 @@ let output_debug_info oc = List.iter (fun (ofs, evl) -> output_binary_int oc ofs; - Array.iter (output_string oc) evl) + Array.iter (output_bytes oc) evl) !debug_info; debug_info := [] @@ -307,7 +316,7 @@ let link_bytecode ppf tolink exec_name standalone = (* The bytecode *) let start_code = pos_out outchan in Symtable.init(); - Consistbl.clear crc_interfaces; + clear_crc_interfaces (); let sharedobjs = List.map Dll.extract_dll_name !Clflags.dllibs in let check_dlls = standalone && Config.target = Config.host in if check_dlls then begin @@ -317,7 +326,7 @@ let link_bytecode ppf tolink exec_name standalone = try Dll.open_dlls Dll.For_checking sharedobjs with Failure reason -> raise(Error(Cannot_open_dll reason)) end; - let output_fun = output_string outchan + let output_fun = output_bytes outchan and currpos_fun () = pos_out outchan - start_code in List.iter (link_file ppf output_fun currpos_fun) tolink; if check_dlls then Dll.close_all_dlls(); @@ -371,12 +380,12 @@ let output_code_string_counter = ref 0 let output_code_string outchan code = let pos = ref 0 in - let len = String.length code in + let len = Bytes.length code in while !pos < len do - let c1 = Char.code(code.[!pos]) in - let c2 = Char.code(code.[!pos + 1]) in - let c3 = Char.code(code.[!pos + 2]) in - let c4 = Char.code(code.[!pos + 3]) in + let c1 = Char.code(Bytes.get code !pos) in + let c2 = Char.code(Bytes.get code (!pos + 1)) in + let c3 = Char.code(Bytes.get code (!pos + 2)) in + let c4 = Char.code(Bytes.get code (!pos + 3)) in pos := !pos + 4; Printf.fprintf outchan "0x%02x%02x%02x%02x, " c4 c3 c2 c1; incr output_code_string_counter; @@ -440,11 +449,11 @@ let link_bytecode_as_c ppf tolink outfile = \n char **argv);\n"; output_string outchan "static int caml_code[] = {\n"; Symtable.init(); - Consistbl.clear crc_interfaces; + clear_crc_interfaces (); let currpos = ref 0 in let output_fun code = output_code_string outchan code; - currpos := !currpos + String.length code + currpos := !currpos + Bytes.length code and currpos_fun () = !currpos in List.iter (link_file ppf output_fun currpos_fun) tolink; (* The final STOP instruction *) @@ -629,3 +638,13 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) + +let reset () = + lib_ccobjs := []; + lib_ccopts := []; + lib_dllibs := []; + missing_globals := IdentSet.empty; + Consistbl.clear crc_interfaces; + implementations_defined := []; + debug_info := []; + output_code_string_counter := 0 diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli index 6e123c3f5..37dad2b52 100644 --- a/bytecomp/bytelink.mli +++ b/bytecomp/bytelink.mli @@ -13,11 +13,12 @@ (* Link .cmo files and produce a bytecode executable. *) val link : Format.formatter -> string list -> string -> unit +val reset : unit -> unit val check_consistency: Format.formatter -> string -> Cmo_format.compilation_unit -> unit -val extract_crc_interfaces: unit -> (string * Digest.t) list +val extract_crc_interfaces: unit -> (string * Digest.t option) list type error = File_not_found of string diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 9c9c1b842..3348f46dc 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -17,6 +17,8 @@ open Misc open Instruct open Cmo_format +module StringSet = Set.Make(String) + type error = Forward_reference of string * Ident.t | Multiple_definition of string * Ident.t @@ -30,6 +32,7 @@ exception Error of error let relocs = ref ([] : (reloc_info * int) list) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let primitives = ref ([] : string list) let force_link = ref false @@ -98,7 +101,9 @@ let read_member_info file = ( if Filename.check_suffix file ".cmo" then begin let ic = open_in_bin file in try - let buffer = input_bytes ic (String.length Config.cmo_magic_number) in + let buffer = + really_input_string ic (String.length Config.cmo_magic_number) + in if buffer <> Config.cmo_magic_number then raise(Error(Not_an_object_file file)); let compunit_pos = input_binary_int ic in @@ -137,6 +142,10 @@ let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in ic compunit.cu_debug; List.iter (relocate_debug ofs prefix subst) (input_value ic); + debug_dirs := List.fold_left + (fun s e -> StringSet.add e s) + !debug_dirs + (input_value ic); end; close_in ic; compunit.cu_codesize @@ -215,6 +224,7 @@ let package_object_files ppf files targetfile targetname coercion = let pos_debug = pos_out oc in if !Clflags.debug && !events <> [] then output_value oc (List.rev !events); + output_value oc (StringSet.elements !debug_dirs); let pos_final = pos_out oc in let imports = List.filter @@ -225,7 +235,8 @@ let package_object_files ppf files targetfile targetname coercion = cu_pos = pos_code; cu_codesize = pos_debug - pos_code; cu_reloc = List.rev !relocs; - cu_imports = (targetname, Env.crc_of_unit targetname) :: imports; + cu_imports = + (targetname, Some (Env.crc_of_unit targetname)) :: imports; cu_primitives = !primitives; cu_force_link = !force_link; cu_debug = if pos_final > pos_debug then pos_debug else 0; @@ -240,7 +251,7 @@ let package_object_files ppf files targetfile targetname coercion = (* The entry point *) -let package_files ppf files targetfile = +let package_files ppf initial_env files targetfile = let files = List.map (fun f -> @@ -251,11 +262,12 @@ let package_files ppf files targetfile = let targetcmi = prefix ^ ".cmi" in let targetname = String.capitalize(Filename.basename prefix) in try - let coercion = Typemod.package_units files targetcmi targetname in - let ret = package_object_files ppf files targetfile targetname coercion in - ret - with x -> - remove_file targetfile; raise x + let coercion = + Typemod.package_units initial_env files targetcmi targetname in + let ret = package_object_files ppf files targetfile targetname coercion in + ret + with x -> + remove_file targetfile; raise x (* Error report *) @@ -285,3 +297,9 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) + +let reset () = + relocs := []; + events := []; + primitives := []; + force_link := false diff --git a/bytecomp/bytepackager.mli b/bytecomp/bytepackager.mli index 04de0726a..69e3c77ac 100644 --- a/bytecomp/bytepackager.mli +++ b/bytecomp/bytepackager.mli @@ -13,7 +13,7 @@ (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) -val package_files: Format.formatter -> string list -> string -> unit +val package_files: Format.formatter -> Env.t -> string list -> string -> unit type error = Forward_reference of string * Ident.t @@ -25,3 +25,4 @@ type error = exception Error of error val report_error: Format.formatter -> error -> unit +val reset: unit -> unit diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml index 5af3bc523..759bde3b2 100644 --- a/bytecomp/bytesections.ml +++ b/bytecomp/bytesections.ml @@ -46,12 +46,14 @@ let read_toc ic = let pos_trailer = in_channel_length ic - 16 in seek_in ic pos_trailer; let num_sections = input_binary_int ic in - let header = Misc.input_bytes ic (String.length Config.exec_magic_number) in + let header = + really_input_string ic (String.length Config.exec_magic_number) + in if header <> Config.exec_magic_number then raise Bad_magic_number; seek_in ic (pos_trailer - 8 * num_sections); section_table := []; for _i = 1 to num_sections do - let name = Misc.input_bytes ic 4 in + let name = really_input_string ic 4 in let len = input_binary_int ic in section_table := (name, len) :: !section_table done @@ -77,7 +79,7 @@ let seek_section ic name = (* Return the contents of a section, as a string *) let read_section_string ic name = - Misc.input_bytes ic (seek_section ic name) + really_input_string ic (seek_section ic name) (* Return the contents of a section, as marshalled data *) @@ -90,3 +92,7 @@ let read_section_struct ic name = let pos_first_section ic = in_channel_length ic - 16 - 8 * List.length !section_table - List.fold_left (fun total (name, len) -> total + len) 0 !section_table + +let reset () = + section_table := []; + section_beginning := 0 diff --git a/bytecomp/bytesections.mli b/bytecomp/bytesections.mli index b9639c1fa..12e679d73 100644 --- a/bytecomp/bytesections.mli +++ b/bytecomp/bytesections.mli @@ -50,3 +50,5 @@ val read_section_struct: in_channel -> string -> 'a val pos_first_section: in_channel -> int (* Return the position of the beginning of the first section *) + +val reset: unit -> unit diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli index abf4f1af3..0c0f08f08 100644 --- a/bytecomp/cmo_format.mli +++ b/bytecomp/cmo_format.mli @@ -27,7 +27,8 @@ type compilation_unit = mutable cu_pos: int; (* Absolute position in file *) cu_codesize: int; (* Size of code block *) cu_reloc: (reloc_info * int) list; (* Relocation information *) - cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *) + cu_imports: + (string * Digest.t option) list; (* Names and CRC of intfs imported *) cu_primitives: string list; (* Primitives declared inside *) mutable cu_force_link: bool; (* Must be linked even if unref'ed *) mutable cu_debug: int; (* Position of debugging info, or 0 *) diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index 5c62b9edc..21688e08e 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -173,3 +173,9 @@ let init_toplevel dllpath = opened_dlls := Array.to_list (get_current_dlls()); names_of_opened_dlls := []; linking_in_core := true + +let reset () = + search_path := []; + opened_dlls :=[]; + names_of_opened_dlls := []; + linking_in_core := false diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli index 975315e26..878ffb919 100644 --- a/bytecomp/dll.mli +++ b/bytecomp/dll.mli @@ -59,3 +59,5 @@ val init_compile: bool -> unit contents of ld.conf file). Take note of the DLLs that were opened when starting the running program. *) val init_toplevel: string -> unit + +val reset: unit -> unit diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 9911de882..77df46110 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -20,6 +20,8 @@ open Instruct open Opcodes open Cmo_format +module StringSet = Set.Make(String) + (* Buffering of bytecode *) let out_buffer = ref(LongString.create 1024) @@ -80,7 +82,7 @@ let label_table = ref ([| |] : label_definition array) let extend_label_table needed = let new_size = ref(Array.length !label_table) in while needed >= !new_size do new_size := 2 * !new_size done; - let new_table = Array.create !new_size (Label_undefined []) in + let new_table = Array.make !new_size (Label_undefined []) in Array.blit !label_table 0 new_table 0 (Array.length !label_table); label_table := new_table @@ -135,8 +137,12 @@ and slot_for_c_prim name = (* Debugging events *) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let record_event ev = + let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in + let abspath = Location.absolute_path path in + debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs; ev.ev_pos <- !out_position; events := ev :: !events @@ -144,8 +150,9 @@ let record_event ev = let init () = out_position := 0; - label_table := Array.create 16 (Label_undefined []); + label_table := Array.make 16 (Label_undefined []); reloc_info := []; + debug_dirs := StringSet.empty; events := [] (* Emission of one instruction *) @@ -353,7 +360,7 @@ let rec emit = function (* Emission to a file *) -let to_file outchan unit_name code = +let to_file outchan unit_name objfile code = init(); output_string outchan cmo_magic_number; let pos_depl = pos_out outchan in @@ -363,8 +370,12 @@ let to_file outchan unit_name code = LongString.output outchan !out_buffer 0 !out_position; let (pos_debug, size_debug) = if !Clflags.debug then begin + debug_dirs := StringSet.add + (Filename.dirname (Location.absolute_path objfile)) + !debug_dirs; let p = pos_out outchan in output_value outchan !events; + output_value outchan (StringSet.elements !debug_dirs); (p, pos_out outchan - p) end else (0, 0) in @@ -373,7 +384,7 @@ let to_file outchan unit_name code = cu_pos = pos_code; cu_codesize = !out_position; cu_reloc = List.rev !reloc_info; - cu_imports = Env.imported_units(); + cu_imports = Env.imports(); cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations; cu_force_link = false; @@ -394,7 +405,7 @@ let to_memory init_code fun_code = emit init_code; emit fun_code; let code = Meta.static_alloc !out_position in - LongString.unsafe_blit_to_string !out_buffer 0 code 0 !out_position; + LongString.unsafe_blit_to_bytes !out_buffer 0 code 0 !out_position; let reloc = List.rev !reloc_info and code_size = !out_position in init(); @@ -409,3 +420,9 @@ let to_packed_file outchan code = let reloc = !reloc_info in init(); reloc + +let reset () = + out_buffer := LongString.create 1024; + out_position := 0; + label_table := [| |]; + reloc_info := [] diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index 60d791434..e2fdb8155 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -15,13 +15,14 @@ open Cmo_format open Instruct -val to_file: out_channel -> string -> instruction list -> unit +val to_file: out_channel -> string -> string -> instruction list -> unit (* Arguments: channel on output file name of compilation unit implemented + path of cmo file being written list of instructions to emit *) val to_memory: instruction list -> instruction list -> - string * int * (reloc_info * int) list + bytes * int * (reloc_info * int) list (* Arguments: initialization code (terminated by STOP) function code @@ -36,3 +37,5 @@ val to_packed_file: list of instructions to emit Result: relocation information (reversed) *) + +val reset: unit -> unit diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 83c00a32d..4ad8e9b4e 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -21,11 +21,19 @@ type compile_time_constant = | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -113,6 +121,8 @@ type primitive = (* byte swap *) | Pbswap16 | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -166,7 +176,7 @@ type lambda = | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list | Lswitch of lambda * lambda_switch - | Lstringswitch of lambda * (string * lambda) list * lambda + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -201,65 +211,91 @@ let const_unit = Const_pointer 0 let lambda_unit = Lconst const_unit -let rec same l1 l2 = - match (l1, l2) with - | Lvar v1, Lvar v2 -> - Ident.same v1 v2 - | Lconst (Const_base (Const_string _)), _ -> - false (* do not share strings *) - | Lconst c1, Lconst c2 -> - c1 = c2 - | Lapply(a1, bl1, _), Lapply(a2, bl2, _) -> - same a1 a2 && samelist same bl1 bl2 - | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> - k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 - | Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) -> - k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2 - | Lletrec (bl1, a1), Lletrec (bl2, a2) -> - samelist samebinding bl1 bl2 && same a1 a2 - | Lprim(p1, al1), Lprim(p2, al2) -> - p1 = p2 && samelist same al1 al2 - | Lswitch(a1, s1), Lswitch(a2, s2) -> - same a1 a2 && sameswitch s1 s2 - | Lstaticraise(n1, al1), Lstaticraise(n2, al2) -> - n1 = n2 && samelist same al1 al2 - | Lstaticcatch(a1, (n1, idl1), b1), Lstaticcatch(a2, (n2, idl2), b2) -> - same a1 a2 && n1 = n2 && samelist Ident.same idl1 idl2 && same b1 b2 - | Ltrywith(a1, id1, b1), Ltrywith(a2, id2, b2) -> - same a1 a2 && Ident.same id1 id2 && same b1 b2 - | Lifthenelse(a1, b1, c1), Lifthenelse(a2, b2, c2) -> - same a1 a2 && same b1 b2 && same c1 c2 - | Lsequence(a1, b1), Lsequence(a2, b2) -> - same a1 a2 && same b1 b2 - | Lwhile(a1, b1), Lwhile(a2, b2) -> - same a1 a2 && same b1 b2 - | Lfor(id1, a1, b1, df1, c1), Lfor(id2, a2, b2, df2, c2) -> - Ident.same id1 id2 && same a1 a2 && - same b1 b2 && df1 = df2 && same c1 c2 - | Lassign(id1, a1), Lassign(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) -> - k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2 - | Levent(a1, ev1), Levent(a2, ev2) -> - same a1 a2 && ev1.lev_loc = ev2.lev_loc - | Lifused(id1, a1), Lifused(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | _, _ -> - false - -and samebinding (id1, c1) (id2, c2) = - Ident.same id1 id2 && same c1 c2 - -and sameswitch sw1 sw2 = - let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in - sw1.sw_numconsts = sw2.sw_numconsts && - sw1.sw_numblocks = sw2.sw_numblocks && - samelist samecase sw1.sw_consts sw2.sw_consts && - samelist samecase sw1.sw_blocks sw2.sw_blocks && - (match (sw1.sw_failaction, sw2.sw_failaction) with - | (None, None) -> true - | (Some a1, Some a2) -> same a1 a2 - | _ -> false) +(* Build sharing keys *) +(* + Those keys are later compared with Pervasives.compare. + For that reason, they should not include cycles. +*) + +exception Not_simple + +let max_raw = 32 + +let make_key e = + let count = ref 0 (* Used for controling size *) + and make_key = Ident.make_key_generator () in + (* make_key is used for normalizing let-bound variables *) + let rec tr_rec env e = + incr count ; + if !count > max_raw then raise Not_simple ; (* Too big ! *) + match e with + | Lvar id -> + begin + try Ident.find_same id env + with Not_found -> e + end + | Lconst (Const_base (Const_string _)|Const_float_array _) -> + (* Mutable constants are not shared *) + raise Not_simple + | Lconst _ -> e + | Lapply (e,es,loc) -> + Lapply (tr_rec env e,tr_recs env es,Location.none) + | Llet (Alias,x,ex,e) -> (* Ignore aliases -> substitute *) + let ex = tr_rec env ex in + tr_rec (Ident.add x ex env) e + | Llet (str,x,ex,e) -> + (* Because of side effects, keep other lets with normalized names *) + let ex = tr_rec env ex in + let y = make_key x in + Llet (str,y,ex,tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p,es) -> + Lprim (p,tr_recs env es) + | Lswitch (e,sw) -> + Lswitch (tr_rec env e,tr_sw env sw) + | Lstringswitch (e,sw,d) -> + Lstringswitch + (tr_rec env e, + List.map (fun (s,e) -> s,tr_rec env e) sw, + tr_opt env d) + | Lstaticraise (i,es) -> + Lstaticraise (i,tr_recs env es) + | Lstaticcatch (e1,xs,e2) -> + Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) + | Ltrywith (e1,x,e2) -> + Ltrywith (tr_rec env e1,x,tr_rec env e2) + | Lifthenelse (cond,ifso,ifnot) -> + Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) + | Lsequence (e1,e2) -> + Lsequence (tr_rec env e1,tr_rec env e2) + | Lassign (x,e) -> + Lassign (x,tr_rec env e) + | Lsend (m,e1,e2,es,loc) -> + Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) + | Lifused (id,e) -> Lifused (id,tr_rec env e) + | Lletrec _|Lfunction _ + | Lfor _ | Lwhile _ +(* Beware: (PR#6412) the event argument to Levent + may include cyclic structure of type Type.typexpr *) + | Levent _ -> + raise Not_simple + + and tr_recs env es = List.map (tr_rec env) es + + and tr_sw env sw = + { sw with + sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; + sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; + sw_failaction = tr_opt env sw.sw_failaction ; } + + and tr_opt env = function + | None -> None + | Some e -> Some (tr_rec env e) in + + try + Some (tr_rec Ident.empty e) + with Not_simple -> None + +(***************) let name_lambda strict arg fn = match arg with @@ -276,6 +312,11 @@ let name_lambda_list args fn = Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in name_list [] args + +let iter_opt f = function + | None -> () + | Some e -> f e + let iter f = function Lvar _ | Lconst _ -> () @@ -294,14 +335,11 @@ let iter f = function f arg; List.iter (fun (key, case) -> f case) sw.sw_consts; List.iter (fun (key, case) -> f case) sw.sw_blocks; - begin match sw.sw_failaction with - | None -> () - | Some l -> f l - end + iter_opt f sw.sw_failaction | Lstringswitch (arg,cases,default) -> f arg ; List.iter (fun (_,act) -> f act) cases ; - f default + iter_opt f default | Lstaticraise (_,args) -> List.iter f args | Lstaticcatch(e1, (_,vars), e2) -> @@ -325,6 +363,7 @@ let iter f = function | Lifused (v, e) -> f e + module IdentSet = Set.Make(struct type t = Ident.t @@ -370,6 +409,12 @@ let next_raise_count () = incr raise_count ; !raise_count +let negative_raise_count = ref 0 + +let next_negative_raise_count () = + decr negative_raise_count ; + !negative_raise_count + (* Anticipated staticraise, for guards *) let staticfail = Lstaticraise (0,[]) @@ -401,7 +446,7 @@ let rec transl_normal_path = function (* Translation of value identifiers *) let transl_path ?(loc=Location.none) env path = - transl_normal_path (Env.normalize_path (Some loc) env path) + transl_normal_path (Env.normalize_path (Some loc) env path) (* Compile a sequence of expressions *) @@ -431,13 +476,10 @@ let subst_lambda s lam = Lswitch(subst arg, {sw with sw_consts = List.map subst_case sw.sw_consts; sw_blocks = List.map subst_case sw.sw_blocks; - sw_failaction = - match sw.sw_failaction with - | None -> None - | Some l -> Some (subst l)}) + sw_failaction = subst_opt sw.sw_failaction; }) | Lstringswitch (arg,cases,default) -> Lstringswitch - (subst arg,List.map subst_strcase cases,subst default) + (subst arg,List.map subst_strcase cases,subst_opt default) | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) @@ -453,6 +495,9 @@ let subst_lambda s lam = and subst_decl (id, exp) = (id, subst exp) and subst_case (key, case) = (key, subst case) and subst_strcase (key, case) = (key, subst case) + and subst_opt = function + | None -> None + | Some e -> Some (subst e) in subst lam @@ -477,3 +522,29 @@ let raise_kind = function | Raise_regular -> "raise" | Raise_reraise -> "reraise" | Raise_notrace -> "raise_notrace" + +let lam_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let (file, lnum, cnum) = Location.get_pos_info loc_start in + let enum = loc.Location.loc_end.Lexing.pos_cnum - + loc_start.Lexing.pos_cnum + cnum in + match kind with + | Loc_POS -> + Lconst (Const_block (0, [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ])) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> Lconst (Const_immstring + (String.capitalize + (Filename.chop_extension (Filename.basename file)))) + | Loc_LOC -> + let loc = Printf.sprintf "File %S, line %d, characters %d-%d" + file lnum cnum enum in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) + +let reset () = + raise_count := 0 diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 6748fefe1..0e038d93d 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -21,11 +21,19 @@ type compile_time_constant = | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -113,6 +121,8 @@ type primitive = (* byte swap *) | Pbswap16 | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -177,7 +187,7 @@ type lambda = | Lswitch of lambda * lambda_switch (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) - | Lstringswitch of lambda * (string * lambda) list * lambda + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -207,7 +217,9 @@ and lambda_event_kind = | Lev_after of Types.type_expr | Lev_function -val same: lambda -> lambda -> bool +(* Sharing key *) +val make_key: lambda -> lambda option + val const_unit: structured_constant val lambda_unit: lambda val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda @@ -234,7 +246,11 @@ val negate_comparison : comparison -> comparison (* Get a new static failure ident *) val next_raise_count : unit -> int - +val next_negative_raise_count : unit -> int + (* Negative raise counts are used to compile 'match ... with + exception x -> ...'. This disabled some simplifications + performed by the Simplif module that assume that static raises + are in tail position in their handler. *) val staticfail : lambda (* Anticipated static failure *) @@ -243,3 +259,6 @@ val is_guarded: lambda -> bool val patch_guarded : lambda -> lambda -> lambda val raise_kind: raise_kind -> string +val lam_of_loc : loc_kind -> Location.t -> lambda + +val reset: unit -> unit diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 3ec3611ba..cba32391e 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -21,6 +21,7 @@ open Lambda open Parmatch open Printf + let dbg = false (* See Peyton-Jones, ``The Implementation of functional programming @@ -40,6 +41,10 @@ let dbg = false - Jump summaries: mapping from exit numbers to contexts *) +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam ; + Format.flush_str_formatter () + type matrix = pattern list list let add_omega_column pss = List.map (fun ps -> omega::ps) pss @@ -164,7 +169,7 @@ let ctx_matcher p = match p.pat_desc with | Tpat_construct (_, cstr,omegas) -> begin match cstr.cstr_tag with - | Cstr_exception _ -> (* exception matching *) + | Cstr_extension _ -> let nargs = List.length omegas in (fun q rem -> match q.pat_desc with | Tpat_construct (_, cstr',args) @@ -443,68 +448,97 @@ let pretty_precompiled_res first nexts = -(* A slight attempt to identify semantically equivalent lambda-expressions, - We could have used Lambda.same, but our goal here is also to +(* Identifing some semantically equivalent lambda-expressions, + Our goal here is also to find alpha-equivalent (simple) terms *) -exception Not_simple -let rec raw_rec env : lambda -> lambda = function - | Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body - | Lvar id as l -> - begin try List.assoc id env with - | Not_found -> l - end - | Lprim (Pfield i,args) -> - Lprim (Pfield i, List.map (raw_rec env) args) - | Lconst (Const_base (Const_string _)) -> - raise Not_simple (* do not share strings *) - | Lconst _ as l -> l - | Lstaticraise (i,args) -> - Lstaticraise (i, List.map (raw_rec env) args) - | _ -> raise Not_simple +(* However, as shown by PR#6359 such sharing may hinders the + lambda-code invariant that all bound idents are unique, + when switchs are compiled to test sequences. + The definitive fix is the systematic introduction of exit/catch + in case action sharing is present. +*) + + +module StoreExp = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + + +let make_exit i = Lstaticraise (i,[]) + +(* Introduce a catch, if worth it *) +let make_catch d k = match d with +| Lstaticraise (_,[]) -> k d +| _ -> + let e = next_raise_count () in + Lstaticcatch (k (make_exit e),(e,[]),d) + +(* Introduce a catch, if worth it, delayed version *) +let rec as_simple_exit = function + | Lstaticraise (i,[]) -> Some i + | Llet (Alias,_,_,e) -> as_simple_exit e + | _ -> None + -let raw_action l = try raw_rec [] l with Not_simple -> l +let make_catch_delayed handler = match as_simple_exit handler with +| Some i -> i,(fun act -> act) +| None -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); +*) + i, + (fun body -> match body with + | Lstaticraise (j,_) -> + if i=j then handler else body + | _ -> Lstaticcatch (body,(i,[]),handler)) + + +let raw_action l = + match make_key l with | Some l -> l | None -> l + + +let tr_raw act = match make_key act with +| Some act -> act +| None -> raise Exit let same_actions = function | [] -> None | [_,act] -> Some act | (_,act0) :: rem -> try - let raw_act0 = raw_rec [] act0 in + let raw_act0 = tr_raw act0 in let rec s_rec = function | [] -> Some act0 | (_,act)::rem -> - if raw_act0 = raw_rec [] act then + if raw_act0 = tr_raw act then s_rec rem else None in s_rec rem with - | Not_simple -> None + | Exit -> None -let equal_action act1 act2 = - try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - raw1 = raw2 - with - | Not_simple -> false (* Test for swapping two clauses *) let up_ok_action act1 act2 = try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - match raw1, raw2 with - | Lstaticraise (i1,[]), Lstaticraise (i2,[]) -> i1=i2 - | _,_ -> raw1 = raw2 + let raw1 = tr_raw act1 + and raw2 = tr_raw act2 in + raw1 = raw2 with - | Not_simple -> false + | Exit -> false -(* Nothing is kown about exeception patterns, because of potential rebind *) +(* Nothing is kown about exception/extension patterns, + because of potential rebind *) let rec exc_inside p = match p.pat_desc with - | Tpat_construct (_,{cstr_tag=Cstr_exception _},_) -> true + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true | Tpat_any|Tpat_constant _|Tpat_var _ | Tpat_construct (_,_,[]) | Tpat_variant (_,None,_) @@ -626,7 +660,7 @@ let rec what_is_cases cases = match cases with (* A few operation on default environments *) let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) -(* For exception matching, record no imformation in matrix *) +(* For extension matching, record no imformation in matrix *) let as_matrix_omega cases = get_mins le_pats (List.map @@ -902,9 +936,8 @@ let rec split_or argo cls args def = do_split [] [] [] cls -(* Ultra-naive spliting, close to semantics, - used for exception, as potential rebind prevents any kind of - optimisation *) +(* Ultra-naive spliting, close to semantics, used for extension, + as potential rebind prevents any kind of optimisation *) and split_naive cls args def k = @@ -961,7 +994,7 @@ and split_naive cls args def k = | (p::_,_ as cl)::rem -> if group_constructor p then split_exc (pat_as_constr p) [cl] rem - else + else split_noexc [cl] rem | _ -> assert false @@ -969,7 +1002,7 @@ and split_constr cls args def k = let ex_pat = what_is_cases cls in match ex_pat.pat_desc with | Tpat_any -> precompile_var args cls def k - | Tpat_construct (_,{cstr_tag=Cstr_exception _},_) -> + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> split_naive cls args def k | _ -> @@ -1079,7 +1112,7 @@ and dont_precompile_var args cls def k = and is_exc p = match p.pat_desc with | Tpat_or (p1,p2,_) -> is_exc p1 || is_exc p2 | Tpat_alias (p,v,_) -> is_exc p -| Tpat_construct (_,{cstr_tag = Cstr_exception _},_) -> true +| Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true | _ -> false and precompile_or argo cls ors args def k = match ors with @@ -1315,12 +1348,12 @@ let make_constr_matching p def ctx = function | ((arg, mut) :: argl) -> let cstr = pat_as_constr p in let newargs = - if cstr.cstr_inlined then + if cstr.cstr_inlined <> None then (arg, Alias) :: argl else match cstr.cstr_tag with Cstr_constant _ | Cstr_block _ -> make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl - | Cstr_exception _ -> + | Cstr_extension _ -> make_field_args Alias arg 1 cstr.cstr_arity argl in {pm= {cases = []; args = newargs; @@ -1451,7 +1484,7 @@ let get_mod_field modname field = lazy ( try let mod_ident = Ident.create_persistent modname in - let env = Env.open_pers_signature modname Env.initial in + let env = Env.open_pers_signature modname Env.initial_safe_string in let p = try match Env.lookup_value (Longident.Lident field) env with | (Path.Pdot(_,_,i), _) -> i @@ -1573,7 +1606,7 @@ let divide_tuple arity p ctx pm = let record_matching_line num_fields lbl_pat_list = - let patv = Array.create num_fields omega in + let patv = Array.make num_fields omega in List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv @@ -1599,7 +1632,7 @@ let make_record_matching all_labels def = function match lbl.lbl_repres with Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos | Record_float -> Pfloatfield lbl.lbl_pos - | Record_exception _ -> Pfield (lbl.lbl_pos + 1) + | Record_extension -> Pfield (lbl.lbl_pos + 1) in let str = match lbl.lbl_mut with @@ -1656,9 +1689,10 @@ let divide_array kind ctx pm = (make_array_matching kind) (=) get_key_array get_args_array ctx pm + (* Specific string test sequence - Will be called by the bytecode compiler, from bytegen.ml. + Will be called by the bytecode compiler, from bytegen.ml. The strategy is first dichotomic search (we perform 3-way tests with compare_string), then sequence of equality tests when there are less then T=strings_test_threshold static strings to match. @@ -1668,7 +1702,7 @@ let divide_array kind ctx pm = T=8 looks a decent tradeoff. *) -(* Utlities *) +(* Utilities *) let strings_test_threshold = 8 @@ -1687,11 +1721,18 @@ let bind_sw arg k = match arg with | _ -> let id = Ident.create "switch" in Llet (Strict,id,arg,k (Lvar id)) - - + + (* Sequential equality tests *) -let make_test_sequence arg sw d = +let make_string_test_sequence arg sw d = + let d,sw = match d with + | None -> + begin match sw with + | (_,d)::sw -> d,sw + | [] -> assert false + end + | Some d -> d,sw in bind_sw arg (fun arg -> List.fold_right @@ -1703,12 +1744,6 @@ let make_test_sequence arg sw d = k,lam)) sw d) -let catch_sw d k = match d with -| Lstaticraise (_,[]) -> k d -| _ -> - let e = next_raise_count () in - Lstaticcatch (k (Lstaticraise (e,[])),(e,[]),d) - let rec split k xs = match xs with | [] -> assert false | x0::xs -> @@ -1726,9 +1761,11 @@ let tree_way_test arg lt eq gt = (* Dichotomic tree *) -let rec do_make_tree arg sw d = + +let rec do_make_string_test_tree arg sw delta d = let len = List.length sw in - if len <= strings_test_threshold then make_test_sequence arg sw d + if len <= strings_test_threshold+delta then + make_string_test_sequence arg sw d else let lt,(s,act),gt = split len sw in bind_sw @@ -1737,17 +1774,64 @@ let rec do_make_tree arg sw d = [arg; Lconst (Const_immstring s)];)) (fun r -> tree_way_test r - (do_make_tree arg lt d) + (do_make_string_test_tree arg lt delta d) act - (do_make_tree arg gt d)) - -(* Entry point *) -let expand_stringswitch arg sw d = - bind_sw arg (fun arg -> catch_sw d (fun d -> do_make_tree arg sw d)) + (do_make_string_test_tree arg gt delta d)) -(*************************************) -(* To combine sub-matchings together *) -(*************************************) +(* Entry point *) +let expand_stringswitch arg sw d = match d with +| None -> + bind_sw arg + (fun arg -> do_make_string_test_tree arg sw 0 None) +| Some e -> + bind_sw arg + (fun arg -> + make_catch e + (fun d -> do_make_string_test_tree arg sw 1 (Some d))) + +(**********************) +(* Generic test trees *) +(**********************) + +(* Sharing *) + +(* Add handler, if shared *) +let handle_shared () = + let hs = ref (fun x -> x) in + let handle_shared act = match act with + | Switch.Single act -> act + | Switch.Shared act -> + let i,h = make_catch_delayed act in + let ohs = !hs in + hs := (fun act -> h (ohs act)) ; + make_exit i in + hs,handle_shared + + +let share_actions_tree sw d = + let store = StoreExp.mk_store () in +(* Default action is always shared *) + let d = + match d with + | None -> None + | Some d -> Some (store.Switch.act_store_shared d) in +(* Store all other actions *) + let sw = + List.map (fun (cst,act) -> cst,store.Switch.act_store act) sw in + +(* Retrieve all actions, includint potentiel default *) + let acts = store.Switch.act_get_shared () in + +(* Array of actual actions *) + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + +(* Recontruct default and switch list *) + let d = match d with + | None -> None + | Some d -> Some (acts.(d)) in + let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in + !hs,sw,d (* Note: dichotomic search requires sorted input with no duplicates *) let rec uniq_lambda_list sw = match sw with @@ -1785,6 +1869,10 @@ let rec do_tests_nofail tst arg = function act) let make_test_sequence fail tst lt_tst arg const_lambda_list = + let const_lambda_list = sort_lambda_list const_lambda_list in + let hs,const_lambda_list,fail = + share_actions_tree const_lambda_list fail in + let rec make_test_sequence const_lambda_list = if List.length const_lambda_list >= 4 && lt_tst <> Pignore then split_sequence const_lambda_list @@ -1797,10 +1885,9 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list = 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) - + in + hs (make_test_sequence const_lambda_list) -let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg]) let rec explode_inter offset i j act k = if i <= j then @@ -1809,7 +1896,7 @@ let rec explode_inter offset i j act k = k let max_vals cases acts = - let vals = Array.create (Array.length acts) 0 in + let vals = Array.make (Array.length acts) 0 in for i=Array.length cases-1 downto 0 do let l,h,act = cases.(i) in vals.(act) <- h - l + 1 + vals.(act) @@ -1842,65 +1929,6 @@ let as_int_list cases acts = (if default >= 0 then Some acts.(default) else None) -let make_switch_offset arg min_key max_key int_lambda_list default = - let numcases = max_key - min_key + 1 in - let cases = - List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in - let offsetarg = make_offset (-min_key) arg in - Lswitch(offsetarg, - {sw_numconsts = numcases; sw_consts = cases; - sw_numblocks = 0; sw_blocks = []; - sw_failaction = default}) - -let make_switch_switcher arg cases acts = - let l = ref [] in - for i = Array.length cases-1 downto 0 do - l := (i,acts.(cases.(i))) :: !l - done ; - Lswitch(arg, - {sw_numconsts = Array.length cases ; sw_consts = !l ; - 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) - | _ -> () in - List.iter (fun (_,lam) -> seen lam) sw.sw_consts ; - List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ; - let i_max = ref (-1) - and max = ref (-1) in - Hashtbl.iter - (fun i c -> - if c > !max then begin - i_max := i ; - max := c - end) t ; - if !i_max >= 0 then - let default = !i_max in - let rec remove = function - | [] -> [] - | (_,Lstaticraise (j,[]))::rem when j=default -> - remove rem - | x::rem -> x::remove rem in - Lswitch - (arg, - {sw with -sw_consts = remove sw.sw_consts ; -sw_blocks = remove sw.sw_blocks ; -sw_failaction = Some (Lstaticraise (default,[]))}) - else - Lswitch (arg,sw) -| _ -> Lswitch (arg,sw) - module SArg = struct type primitive = Lambda.primitive @@ -1917,6 +1945,7 @@ module SArg = struct let make_offset arg n = match n with | 0 -> arg | _ -> Lprim (Poffsetint n,[arg]) + let bind arg body = let newvar,newarg = match arg with | Lvar v -> v,arg @@ -1924,13 +1953,89 @@ module SArg = struct let newvar = Ident.create "switcher" in newvar,Lvar newvar in bind Alias newvar arg (body newarg) - + let make_const i = Lconst (Const_base (Const_int i)) let make_isout h arg = Lprim (Pisout, [h ; arg]) let make_isin h arg = Lprim (Pnot,[make_isout h arg]) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch = make_switch_switcher + let make_switch arg cases acts = + let l = ref [] in + for i = Array.length cases-1 downto 0 do + l := (i,acts.(cases.(i))) :: !l + done ; + Lswitch(arg, + {sw_numconsts = Array.length cases ; sw_consts = !l ; + sw_numblocks = 0 ; sw_blocks = [] ; + sw_failaction = None}) + let make_catch = make_catch_delayed + let make_exit = make_exit + end +(* Action sharing for Lswitch argument *) +let share_actions_sw sw = +(* Attempt sharing on all actions *) + let store = StoreExp.mk_store () in + let fail = match sw.sw_failaction with + | None -> None + | Some fail -> + (* Fail is translated to exit, whatever happens *) + Some (store.Switch.act_store_shared fail) in + let consts = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_consts + and blocks = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_blocks in + let acts = store.Switch.act_get_shared () in + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + let fail = match fail with + | None -> None + | Some fail -> Some (acts.(fail)) in + !hs, + { sw with + sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; + sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; + sw_failaction = fail; } + +(* Reintroduce fail action in switch argument, + for the sake of avoiding carrying over huge switches *) + +let reintroduce_fail sw = match sw.sw_failaction with +| None -> + let t = Hashtbl.create 17 in + let seen (_,l) = match as_simple_exit l with + | Some i -> + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old+1) + | None -> () in + List.iter seen sw.sw_consts ; + List.iter seen sw.sw_blocks ; + let i_max = ref (-1) + and max = ref (-1) in + Hashtbl.iter + (fun i c -> + if c > !max then begin + i_max := i ; + max := c + end) t ; + if !max >= 3 then + let default = !i_max in + let remove = + List.filter + (fun (_,lam) -> match as_simple_exit lam with + | Some j -> j <> default + | None -> true) in + {sw with + sw_consts = remove sw.sw_consts ; + sw_blocks = remove sw.sw_blocks ; + sw_failaction = Some (make_exit default)} + else sw +| Some _ -> sw + + module Switcher = Switch.Make(SArg) open Switch @@ -1947,7 +2052,16 @@ let get_edges low high l = match l with let as_interval_canfail fail low high l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in + + let do_store tag act = + let i = store.act_store act in +(* + Printlambda.lambda Format.str_formatter act ; + eprintf "STORE [%s] %i %s\n" tag i (Format.flush_str_formatter ()) ; +*) + i in + let rec nofail_rec cur_low cur_high cur_act = function | [] -> if cur_high = high then @@ -1955,7 +2069,7 @@ let as_interval_canfail fail low high l = else [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] | ((i,act_i)::rem) as all -> - let act_index = store.act_store act_i in + let act_index = do_store "NO" act_i in if cur_high+1= i then if act_index=cur_act then nofail_rec cur_low i cur_act rem @@ -1963,14 +2077,18 @@ let as_interval_canfail fail low high l = (cur_low,i-1, cur_act)::fail_rec i i rem else (cur_low, i-1, cur_act)::nofail_rec i i act_index rem + else if act_index = 0 then + (cur_low, cur_high, cur_act):: + fail_rec (cur_high+1) (cur_high+1) all else (cur_low, cur_high, cur_act):: - fail_rec ((cur_high+1)) (cur_high+1) all + (cur_high+1,i-1,0):: + nofail_rec i i act_index rem and fail_rec cur_low cur_high = function | [] -> [(cur_low, cur_high, 0)] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "YES" act_i in if index=0 then fail_rec cur_low i rem else (cur_low,i-1,0):: @@ -1979,7 +2097,7 @@ let as_interval_canfail fail low high l = let init_rec = function | [] -> [] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "INIT" act_i in if index=0 then fail_rec low i rem else @@ -1988,12 +2106,12 @@ let as_interval_canfail fail low high l = else nofail_rec i i index rem in - ignore (store.act_store fail) ; (* fail has action index 0 *) + assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) let r = init_rec l in - Array.of_list r, store.act_get () + Array.of_list r, store let as_interval_nofail l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in let rec i_rec cur_low cur_high cur_act = function | [] -> @@ -2011,7 +2129,7 @@ let as_interval_nofail l = i_rec i i act_index rem | _ -> assert false in - Array.of_list inters, store.act_get () + Array.of_list inters, store let sort_int_lambda_list l = @@ -2029,10 +2147,10 @@ let as_interval fail low high l = | None -> as_interval_nofail l | Some act -> as_interval_canfail act low high l) -let call_switcher konst fail arg low high int_lambda_list = +let call_switcher fail arg low high int_lambda_list = let edges, (cases, actions) = as_interval fail low high int_lambda_list in - Switcher.zyva edges konst arg cases actions + Switcher.zyva edges arg cases actions let exists_ctx ok ctx = @@ -2187,33 +2305,27 @@ let combine_constant arg cst partial ctx def let int_lambda_list = List.map (function Const_int n, l -> n,l | _ -> assert false) const_lambda_list in - call_switcher - lambda_of_int fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list | Const_char _ -> let int_lambda_list = List.map (function Const_char c, l -> (Char.code c, l) | _ -> assert false) const_lambda_list in - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg 0 255 int_lambda_list + call_switcher fail arg 0 255 int_lambda_list | Const_string _ -> (* Note as the bytecode compiler may resort to dichotmic search, the clauses of strinswitch are sorted with duplicate removed. This partly applies to the native code compiler, which requires - no duplicates *) - let fail,const_lambda_list = match fail with - | Some fail -> fail,sort_lambda_list const_lambda_list - | None -> - let cls,(_,lst) = Misc.split_last const_lambda_list in - lst,sort_lambda_list cls in + no duplicates *) + let const_lambda_list = sort_lambda_list const_lambda_list in let sw = List.map (fun (c,act) -> match c with | Const_string (s,_) -> s,act | _ -> assert false) const_lambda_list in - Lstringswitch (arg,sw,fail) + let hs,sw,fail = share_actions_tree sw fail in + hs (Lstringswitch (arg,sw,fail)) | Const_float _ -> make_test_sequence fail @@ -2251,39 +2363,61 @@ let split_cases tag_lambda_list = sort_int_lambda_list const, sort_int_lambda_list nonconst +let split_extension_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts) + | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts) + | _ -> assert false in + split_rec tag_lambda_list + let combine_constructor arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = if cstr.cstr_consts < 0 then begin - (* Special cases for exceptions *) + (* Special cases for extensions *) let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in let tag_lambda_list = to_add@tag_lambda_list in let lambda1 = - let default, tests = + let consts, nonconsts = split_extension_cases tag_lambda_list in + let default, consts, nonconsts = match fail with | None -> - begin match tag_lambda_list with - | (_, act)::rem -> act,rem + begin match consts, nonconsts with + | _, (_, act)::rem -> act, consts, rem + | (_, act)::rem, _ -> act, rem, nonconsts | _ -> assert false end - | Some fail -> fail, tag_lambda_list in - List.fold_right - (fun (ex, act) rem -> - assert(ex = cstr.cstr_tag); - match ex with - | Cstr_exception (path, _) -> - let slot = - if cstr.cstr_arity = 0 then arg - else Lprim(Pfield 0, [arg]) - in - Lifthenelse(Lprim(Pintcomp Ceq, - [slot; - transl_path ~loc:ex_pat.pat_loc - ex_pat.pat_env path]), - act, rem) - | _ -> assert false) - tests default in + | Some fail -> fail, consts, nonconsts in + let nonconst_lambda = + match nonconsts with + [] -> default + | _ -> + let tag = Ident.create "tag" in + let tests = + List.fold_right + (fun (path, act) rem -> + Lifthenelse(Lprim(Pintcomp Ceq, + [Lvar tag; + transl_path ex_pat.pat_env path]), + act, rem)) + nonconsts + default + in + Llet(Alias, tag, Lprim(Pfield 0, [arg]), tests) + in + List.fold_right + (fun (path, act) rem -> + Lifthenelse(Lprim(Pintcomp Ceq, + [arg; transl_path ex_pat.pat_env path]), + act, rem)) + consts + nonconst_lambda + in lambda1, jumps_union local_jumps total1 end else begin (* Regular concrete type *) @@ -2307,22 +2441,22 @@ let combine_constructor arg ex_pat cstr partial ctx def | (1, 1, [0, act1], [0, act2]) -> Lifthenelse(arg, act2, act1) | (n,_,_,[]) -> - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - None arg 0 (n-1) consts + call_switcher None arg 0 (n-1) consts | (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}) +(* Emit a switch, as bytecode implements this sophisticated instruction *) + let sw = + {sw_numconsts = cstr.cstr_consts; sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; + sw_failaction = None} in + let hs,sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg,sw)) | Some act -> Lifthenelse (Lprim (Pisint, [arg]), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) None arg 0 (n-1) consts, act) in @@ -2332,20 +2466,16 @@ let combine_constructor arg ex_pat cstr partial ctx def let make_test_sequence_variant_constant fail arg int_lambda_list = let _, (cases, actions) = as_interval fail min_int max_int int_lambda_list in - Switcher.test_sequence - (fun i -> Lconst (Const_base (Const_int i))) arg cases actions + Switcher.test_sequence arg cases actions let call_switcher_variant_constant fail arg int_lambda_list = - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list let call_switcher_variant_constr fail arg int_lambda_list = let v = Ident.create "variant" in Llet(Alias, v, Lprim(Pfield 0, [arg]), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) fail (Lvar v) min_int max_int int_lambda_list) let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = @@ -2409,7 +2539,6 @@ let combine_array arg kind partial ctx def let newvar = Ident.create "len" in let switch = call_switcher - lambda_of_int fail (Lvar newvar) 0 max_int len_lambda_list in bind @@ -2528,10 +2657,6 @@ let rec approx_present v = function | Lvar vv -> Ident.same v vv | _ -> true -let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam ; - Format.flush_str_formatter () - let rec lower_bind v arg lam = match lam with | Lifthenelse (cond, ifso, ifnot) -> let pcond = approx_present v cond diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 398143778..88002e056 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -37,13 +37,7 @@ exception Cannot_flatten val flatten_pattern: int -> pattern -> pattern list (* Expand stringswitch to string test tree *) - -val expand_stringswitch: lambda -> (string * lambda) list -> lambda -> lambda - -(* -val make_test_sequence: - lambda option -> primitive -> primitive -> lambda -> - (Asttypes.constant * lambda) list -> lambda -*) +val expand_stringswitch: + lambda -> (string * lambda) list -> lambda option -> lambda val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml index 35d877666..f7711ff15 100644 --- a/bytecomp/meta.ml +++ b/bytecomp/meta.ml @@ -12,13 +12,13 @@ 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_resize : string -> int -> string = "caml_static_resize" -external static_release_bytecode : string -> int -> unit +external static_alloc : int -> bytes = "caml_static_alloc" +external static_free : bytes -> unit = "caml_static_free" +external static_resize : bytes -> int -> bytes = "caml_static_resize" +external static_release_bytecode : bytes -> int -> unit = "caml_static_release_bytecode" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" +external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli index a8ef5272a..cb3565dcc 100644 --- a/bytecomp/meta.mli +++ b/bytecomp/meta.mli @@ -14,13 +14,13 @@ 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 +external static_alloc : int -> bytes = "caml_static_alloc" +external static_free : bytes -> unit = "caml_static_free" +external static_release_bytecode : bytes -> int -> unit = "caml_static_release_bytecode" -external static_resize : string -> int -> string = "caml_static_resize" +external static_resize : bytes -> int -> bytes = "caml_static_resize" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" +external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 7e9c197e3..1b9085edd 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -86,14 +86,22 @@ let record_rep ppf r = | Record_regular -> fprintf ppf "regular" | Record_inlined i -> fprintf ppf "inlined(%i)" i | Record_float -> fprintf ppf "float" - | Record_exception p -> fprintf ppf "exn (%s)" (Path.name p) + | Record_extension -> fprintf ppf "ext" ;; +let string_of_loc_kind = function + | Loc_FILE -> "loc_FILE" + | Loc_LINE -> "loc_LINE" + | Loc_MODULE -> "loc_MODULE" + | Loc_POS -> "loc_POS" + | Loc_LOC -> "loc_LOC" + let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pignore -> fprintf ppf "ignore" | Prevapply _ -> fprintf ppf "revapply" | Pdirapply _ -> fprintf ppf "dirapply" + | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag @@ -231,6 +239,7 @@ let primitive ppf = function else fprintf ppf "bigarray.array1.set64" | Pbswap16 -> fprintf ppf "bswap16" | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi + | Pint_as_pointer -> fprintf ppf "int_as_pointer" let rec lam ppf = function | Lvar id -> @@ -313,8 +322,12 @@ let rec lam ppf = function if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[<hv 1>case \"%s\":@ %a@]" (String.escaped s) lam l) cases; - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<hv 1>default:@ %a@]" lam default in + begin match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<hv 1>default:@ %a@]" lam default + | None -> () + end in fprintf ppf "@[<1>(stringswitch %a@ @[<v 0>%a@])@]" lam arg switch cases | Lstaticraise (i, ls) -> diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index c03cd857e..fd3d21c17 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -51,14 +51,13 @@ let rec eliminate_ref id = function sw_numblocks = sw.sw_numblocks; sw_blocks = List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; - sw_failaction = match sw.sw_failaction with - | None -> None - | Some l -> Some (eliminate_ref id l)}) + sw_failaction = + Misc.may_map (eliminate_ref id) sw.sw_failaction; }) | Lstringswitch(e, sw, default) -> Lstringswitch (eliminate_ref id e, List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, - eliminate_ref id default) + Misc.may_map (eliminate_ref id) default) | Lstaticraise (i,args) -> Lstaticraise (i,List.map (eliminate_ref id) args) | Lstaticcatch(e1, i, e2) -> @@ -123,7 +122,12 @@ let simplify_exits lam = | Lstringswitch(l, sw, d) -> count l; List.iter (fun (_, l) -> count l) sw; - count d + begin match d with + | None -> () + | Some d -> match sw with + | []|[_] -> count d + | _ -> count d; count d (* default will get replicated *) + end | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> (* i will be replaced by j in l1, so each occurence of i in l1 @@ -147,10 +151,7 @@ let simplify_exits lam = | Lsequence(l1, l2) -> count l1; count l2 | Lwhile(l1, l2) -> count l1; count l2 | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 - | Lassign(v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcount *) - count l + | Lassign(v, l) -> count l | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll) | Levent(l, _) -> count l | Lifused(v, l) -> count l @@ -218,16 +219,15 @@ let simplify_exits lam = let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) | Lstringswitch(l,sw,d) -> Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw,simplif d) + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d) | Lstaticraise (i,[]) as l -> begin try let _,handler = Hashtbl.find subst i in @@ -253,17 +253,10 @@ let simplify_exits lam = | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> Hashtbl.add subst i ([],simplif l2) ; simplif l1 - | Lstaticcatch (l1,(i,xs), (Lvar _ as l2)) -> - begin match count_exit i with - | 0 -> simplif l1 - | _ -> - Hashtbl.add subst i (xs,l2) ; - simplif l1 - end | Lstaticcatch (l1,(i,xs),l2) -> begin match count_exit i with | 0 -> simplif l1 - | 1 -> + | 1 when i >= 0 -> Hashtbl.add subst i (xs,simplif l2) ; simplif l1 | _ -> @@ -376,7 +369,14 @@ let simplify_lets lam = | Lstringswitch(l, sw, d) -> count bv l ; List.iter (fun (_, l) -> count bv l) sw ; - count bv d + begin match d with + | Some d -> + begin match sw with + | []|[_] -> count bv d + | _ -> count bv d ; count bv d + end + | None -> () + end | Lstaticraise (i,ls) -> List.iter (count bv) ls | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2 | Ltrywith(l1, v, l2) -> count bv l1; count bv l2 @@ -469,16 +469,15 @@ let simplify_lets lam = let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) | Lstringswitch (l,sw,d) -> Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw,simplif d) + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d) | Lstaticraise (i,ls) -> Lstaticraise (i, List.map simplif ls) | Lstaticcatch(l1, (i,args), l2) -> @@ -539,13 +538,14 @@ let rec emit_tail_infos is_tail lambda = | Lswitch (lam, sw) -> emit_tail_infos false lam; list_emit_tail_infos_fun snd is_tail sw.sw_consts; - list_emit_tail_infos_fun snd is_tail sw.sw_blocks + list_emit_tail_infos_fun snd is_tail sw.sw_blocks; + Misc.may (emit_tail_infos is_tail) sw.sw_failaction | Lstringswitch (lam, sw, d) -> emit_tail_infos false lam; List.iter (fun (_,lam) -> emit_tail_infos is_tail lam) sw ; - emit_tail_infos is_tail d + Misc.may (emit_tail_infos is_tail) d | Lstaticraise (_, l) -> list_emit_tail_infos false l | Lstaticcatch (body, _, handler) -> diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index ff193ee13..da9a48f1a 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -10,31 +10,81 @@ (* *) (***********************************************************************) -(* Store for actions in object style *) -exception Found of int + +type 'a shared = Shared of 'a | Single of 'a + +let share_out = function + | Shared act|Single act -> act + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} - -let mk_store same = - let r_acts = ref [] in - let store act = - let rec store_rec i = function - | [] -> i,[act] - | act0::rem -> - if same act0 act then raise (Found i) - else - let i,rem = store_rec (i+1) rem in - i,act0::rem in - try - let i,acts = store_rec 0 !r_acts in - r_acts := acts ; - i - with - | Found i -> i + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } - and get () = Array.of_list !r_acts in - {act_store=store ; act_get=get} +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end + +module Store(A:Stored) = struct + module AMap = + Map.Make(struct type t = A.key let compare = Pervasives.compare end) + + type intern = + { mutable map : (bool * int) AMap.t ; + mutable next : int ; + mutable acts : (bool * A.t) list; } + + let mk_store () = + let st = + { map = AMap.empty ; + next = 0 ; + acts = [] ; } in + + let add mustshare act = + let i = st.next in + st.acts <- (mustshare,act) :: st.acts ; + st.next <- i+1 ; + i in + + let store mustshare act = match A.make_key act with + | Some key -> + begin try + let (shared,i) = AMap.find key st.map in + if not shared then st.map <- AMap.add key (true,i) st.map ; + i + with Not_found -> + let i = add mustshare act in + st.map <- AMap.add key (mustshare,i) st.map ; + i + end + | None -> + add mustshare act + + and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) + + and get_shared () = + let acts = + Array.of_list + (List.rev_map + (fun (shared,act) -> + if shared then Shared act else Single act) + st.acts) in + AMap.iter + (fun _ (shared,i) -> + if shared then match acts.(i) with + | Single act -> acts.(i) <- Shared act + | Shared _ -> ()) + st.map ; + acts in + {act_store = store false ; act_store_shared = store true ; + act_get = get; act_get_shared = get_shared; } +end @@ -50,13 +100,15 @@ module type S = type act val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act val make_isin : act -> act -> act val make_if : act -> act -> act -> act - val make_switch : - act -> int array -> act array -> act + val make_switch : act -> int array -> act array -> act + val make_catch : act -> int * (act -> act) + val make_exit : int -> act end (* The module will ``produce good code for the case statement'' *) @@ -196,7 +248,7 @@ let case_append c1 c2 = let l1,h1,act1 = c1.(Array.length c1-1) and l2,h2,act2 = c2.(0) in if act1 = act2 then - let r = Array.create (len1+len2-1) c1.(0) in + let r = Array.make (len1+len2-1) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -225,7 +277,7 @@ let case_append c1 c2 = done ; r else if h1 > l1 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -235,7 +287,7 @@ let case_append c1 c2 = done ; r else if h2 > l2 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-1 do r.(i) <- c1.(i) done ; @@ -489,77 +541,77 @@ and enum top cases = end ; !r, !rc - let make_if_test konst test arg i ifso ifnot = + let make_if_test test arg i ifso ifnot = Arg.make_if - (Arg.make_prim test [arg ; konst i]) + (Arg.make_prim test [arg ; Arg.make_const i]) ifso ifnot - let make_if_lt konst arg i ifso ifnot = match i with + let make_if_lt arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.leint arg 0 ifso ifnot + make_if_test Arg.leint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.ltint arg i ifso ifnot + make_if_test Arg.ltint arg i ifso ifnot - and make_if_le konst arg i ifso ifnot = match i with + and make_if_le arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.ltint arg 0 ifso ifnot + make_if_test Arg.ltint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.leint arg i ifso ifnot + make_if_test Arg.leint arg i ifso ifnot - and make_if_gt konst arg i ifso ifnot = match i with + and make_if_gt arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.geint arg 0 ifso ifnot + make_if_test Arg.geint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.gtint arg i ifso ifnot + make_if_test Arg.gtint arg i ifso ifnot - and make_if_ge konst arg i ifso ifnot = match i with + and make_if_ge arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.gtint arg 0 ifso ifnot + make_if_test Arg.gtint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.geint arg i ifso ifnot + make_if_test Arg.geint arg i ifso ifnot - and make_if_eq konst arg i ifso ifnot = - make_if_test konst Arg.eqint arg i ifso ifnot + and make_if_eq arg i ifso ifnot = + make_if_test Arg.eqint arg i ifso ifnot - and make_if_ne konst arg i ifso ifnot = - make_if_test konst Arg.neint arg i ifso ifnot + and make_if_ne arg i ifso ifnot = + make_if_test Arg.neint arg i ifso ifnot let do_make_if_out h arg ifso ifno = Arg.make_if (Arg.make_isout h arg) ifso ifno - let make_if_out konst ctx l d mk_ifso mk_ifno = match l with + let make_if_out ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_out - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_out - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) let do_make_if_in h arg ifso ifno = Arg.make_if (Arg.make_isin h arg) ifso ifno - let make_if_in konst ctx l d mk_ifso mk_ifno = match l with + let make_if_in ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_in - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_in - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) - + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - let rec c_test konst ctx ({cases=cases ; actions=actions} as s) = + let rec c_test ctx ({cases=cases ; actions=actions} as s) = let lcases = Array.length cases in assert(lcases > 0) ; if lcases = 1 then actions.(get_act cases 0) ctx + else begin let w,c = opt_count false cases in @@ -579,31 +631,31 @@ and enum top cases = if low=high then begin if less_tests coutside cinside then make_if_eq - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=inside}) - (c_test konst ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) else make_if_ne - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=outside}) - (c_test konst ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) end else begin if less_tests coutside cinside then make_if_in - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=inside}) - (fun ctx -> c_test konst ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) else make_if_out - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=outside}) - (fun ctx -> c_test konst ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) end | Sep i -> let lim,left,right = coupe cases i in @@ -613,17 +665,17 @@ and enum top cases = and right = {s with cases=right} in if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then - make_if_ne konst + make_if_ne ctx.arg 0 - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) else if less_tests cright cleft then - make_if_lt konst + make_if_lt ctx.arg (lim+ctx.off) - (c_test konst ctx left) (c_test konst ctx right) + (c_test ctx left) (c_test ctx right) else - make_if_ge konst + make_if_ge ctx.arg (lim+ctx.off) - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) end @@ -676,8 +728,8 @@ let dense {cases=cases ; actions=actions} i j = let comp_clusters ({cases=cases ; actions=actions} as s) = let len = Array.length cases in - let min_clusters = Array.create len max_int - and k = Array.create len 0 in + let min_clusters = Array.make len max_int + and k = Array.make len 0 in let get_min i = if i < 0 then 0 else min_clusters.(i) in for i = 0 to len-1 do @@ -697,7 +749,7 @@ let comp_clusters ({cases=cases ; actions=actions} as s) = let make_switch {cases=cases ; actions=actions} i j = let ll,_,_ = cases.(i) and _,hh,_ = cases.(j) in - let tbl = Array.create (hh-ll+1) 0 + let tbl = Array.make (hh-ll+1) 0 and t = Hashtbl.create 17 and index = ref 0 in let get_index act = @@ -717,7 +769,7 @@ let make_switch {cases=cases ; actions=actions} i j = tbl.(kk) <- index done done ; - let acts = Array.create !index actions.(0) in + let acts = Array.make !index actions.(0) in Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t ; @@ -732,7 +784,7 @@ let make_switch {cases=cases ; actions=actions} i j = let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = let len = Array.length cases in - let r = Array.create n_clusters (0,0,0) + let r = Array.make n_clusters (0,0,0) and t = Hashtbl.create 17 and index = ref 0 and bidon = ref (Array.length actions) in @@ -768,13 +820,13 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = if i > 0 then zyva (i-1) (ir-1) in zyva (len-1) (n_clusters-1) ; - let acts = Array.create !index (fun _ -> assert false) in + let acts = Array.make !index (fun _ -> assert false) in Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; {cases = r ; actions = acts} ;; -let zyva (low,high) konst arg cases actions = +let do_zyva (low,high) arg cases actions = let old_ok = !ok_inter in ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -787,12 +839,31 @@ let zyva (low,high) konst arg cases actions = *) let n_clusters,k = comp_clusters s in let clusters = make_clusters s n_clusters k in - let r = c_test konst {arg=arg ; off=0} clusters in + let r = c_test {arg=arg ; off=0} clusters in r - - -and test_sequence konst arg cases actions = +let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> match act with + | Single act -> act + | Shared act -> + let i,h = Arg.make_catch act in + let oh = !handlers in + handlers := (fun act -> h (oh act)) ; + Arg.make_exit i) + actions in + !handlers,actions + +let zyva lh arg cases actions = + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in + hs (do_zyva lh arg cases actions) + +and test_sequence arg cases actions = + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in let old_ok = !ok_inter in ok_inter := false ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -804,8 +875,7 @@ and test_sequence konst arg cases actions = pcases stderr cases ; prerr_endline "" ; *) - let r = c_test konst {arg=arg ; off=0} s in - r + hs (c_test {arg=arg ; off=0} s) ;; end diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli index 69fc800d3..53fd99748 100644 --- a/bytecomp/switch.mli +++ b/bytecomp/switch.mli @@ -17,9 +17,35 @@ (* For detecting action sharing, object style *) +(* Store for actions in object style: + act_store : store an action, returns index in table + In case an action with equal key exists, returns index + of the stored action. Otherwise add entry in table. + act_store_shared : This stored action will always be shared. + act_get : retrieve table + act_get_shared : retrieve table, with sharing explicit +*) + +type 'a shared = Shared of 'a | Single of 'a + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} -val mk_store : ('a -> 'a -> bool) -> 'a t_store + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end + +module Store(A:Stored) : + sig + val mk_store : unit -> A.t t_store + end (* Arguments to the Make functor *) module type S = @@ -39,6 +65,7 @@ module type S = (* Various constructors, for making a binder, adding one integer, etc. *) val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act @@ -49,12 +76,15 @@ module type S = NB: cases is in the value form *) val make_switch : act -> int array -> act array -> act + (* Build last minute sharing of action stuff *) + val make_catch : act -> int * (act -> act) + val make_exit : int -> act + end (* - Make.zyva mk_const arg low high cases actions where - - mk_const takes an integer sends a constant action. + Make.zyva arg low high cases actions where - arg is the argument of the switch. - low, high are the interval limits. - cases is a list of sub-interval and action indices @@ -66,17 +96,18 @@ module type S = module Make : functor (Arg : S) -> sig +(* Standard entry point, sharing is tracked *) val zyva : (int * int) -> - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act + +(* Output test sequence, sharing tracked *) val test_sequence : - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act end diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index baff51c48..1cc3a5314 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -96,7 +96,7 @@ let require_primitive name = if name.[0] <> '%' then ignore(num_of_prim name) let all_primitives () = - let prim = Array.create !c_prim_table.num_cnt "" in + let prim = Array.make !c_prim_table.num_cnt "" in Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl; prim @@ -198,7 +198,7 @@ let gen_patch_object str_set buff patchlist = gen_patch_int str_set buff pos (num_of_prim name)) patchlist -let patch_object = gen_patch_object String.unsafe_set +let patch_object = gen_patch_object Bytes.unsafe_set let ls_patch_object = gen_patch_object LongString.set (* Translate structured constants *) @@ -226,7 +226,7 @@ let rec transl_const = function (* Build the initial table of globals *) let initial_global_table () = - let glob = Array.create !global_table.num_cnt (Obj.repr 0) in + let glob = Array.make !global_table.num_cnt (Obj.repr 0) in List.iter (fun (slot, cst) -> glob.(slot) <- transl_const cst) !literal_table; @@ -300,7 +300,8 @@ let init_toplevel () = Dll.init_toplevel dllpath; (* Recover CRC infos for interfaces *) let crcintfs = - try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t) list) + try + (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list) with Not_found -> [] in (* Done *) sect.close_reader(); @@ -383,3 +384,8 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) + +let reset () = + global_table := empty_numtable; + literal_table := []; + c_prim_table := empty_numtable diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index e3c33d239..ffc878bf1 100644 --- a/bytecomp/symtable.mli +++ b/bytecomp/symtable.mli @@ -17,7 +17,7 @@ open Cmo_format (* Functions for batch linking *) val init: unit -> unit -val patch_object: string -> (reloc_info * int) list -> unit +val patch_object: bytes -> (reloc_info * int) list -> unit val ls_patch_object: Misc.LongString.t -> (reloc_info * int) list -> unit val require_primitive: string -> unit val initial_global_table: unit -> Obj.t array @@ -29,7 +29,7 @@ val data_primitive_names: unit -> string (* Functions for the toplevel *) -val init_toplevel: unit -> (string * Digest.t) list +val init_toplevel: unit -> (string * Digest.t option) list val update_global_table: unit -> unit val get_global_value: Ident.t -> Obj.t val is_global_defined: Ident.t -> bool @@ -57,3 +57,5 @@ exception Error of error open Format val report_error: formatter -> error -> unit + +val reset: unit -> unit diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 55ddab3bc..0fb68457b 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -116,7 +116,7 @@ let name_pattern default p = | _ -> Ident.create default let normalize_cl_path cl path = - Env.normalize_path (Some cl.cl_loc) cl.cl_env path + Env.normalize_path (Some cl.cl_loc) cl.cl_env path let rec build_object_init cl_table obj params inh_init obj_init cl = match cl.cl_desc with @@ -145,7 +145,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) -> (inh_init, lsequence (set_inst_var obj id exp) obj_init, has_init) - | Tcf_method _ | Tcf_val _ | Tcf_constraint _ -> + | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _-> (inh_init, obj_init, has_init) | Tcf_initializer _ -> (inh_init, obj_init, true) @@ -280,7 +280,9 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = inh_init cl_init msubst top cl in (inh_init, cl_init, [], values) | Tcf_val (name, _, id, _, over) -> - let values = if over then values else (name.txt, id) :: values in + let values = + if over then values else (name.txt, id) :: values + in (inh_init, cl_init, methods, values) | Tcf_method (_, _, Tcfk_virtual _) | Tcf_constraint _ @@ -296,14 +298,16 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = else met_code in (inh_init, cl_init, - Lvar (Meths.find name.txt str.cstr_meths) :: met_code @ methods, + Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods, values) | Tcf_initializer exp -> (inh_init, Lsequence(mkappl (oo_prim "add_initializer", Lvar cla :: msubst false (transl_exp exp)), cl_init), - methods, values)) + methods, values) + | Tcf_attribute _ -> + (inh_init, cl_init, methods, values)) str.cstr_fields (inh_init, cl_init, [], []) in @@ -808,7 +812,7 @@ let transl_class ids cl_id pub_meths cl vflag = (* let cl_id = ci.ci_id_class in (* TODO: cl_id is used somewhere else as typesharp ? *) - let _arity = List.length (fst ci.ci_params) in + let _arity = List.length ci.ci_params in let pub_meths = m in let cl = ci.ci_expr in let vflag = vf in diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index a2d15bf77..14f8b0659 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -311,6 +311,7 @@ let primitives_table = create_hashtable 57 [ "%bswap_int32", Pbbswap(Pint32); "%bswap_int64", Pbbswap(Pint64); "%bswap_native", Pbbswap(Pnativeint); + "%int_as_pointer", Pint_as_pointer; ] let prim_makearray = @@ -325,6 +326,11 @@ let find_primitive loc prim_name = match prim_name with "%revapply" -> Prevapply loc | "%apply" -> Pdirapply loc + | "%loc_LOC" -> Ploc Loc_LOC + | "%loc_FILE" -> Ploc Loc_FILE + | "%loc_LINE" -> Ploc Loc_LINE + | "%loc_POS" -> Ploc Loc_POS + | "%loc_MODULE" -> Ploc Loc_MODULE | name -> Hashtbl.find primitives_table name let transl_prim loc prim args = @@ -404,10 +410,20 @@ let transl_primitive loc p = with Not_found -> Pccall p in match prim with - Plazyforce -> + | Plazyforce -> let parm = Ident.create "prim" in Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none) + | Ploc kind -> + let lam = lam_of_loc kind loc in + begin match p.prim_arity with + | 0 -> lam + | 1 -> (* TODO: we should issue a warning ? *) + let param = Ident.create "prim" in + Lfunction(Curried, [param], + Lprim(Pmakeblock(0, Immutable), [lam; Lvar param])) + | _ -> assert false + end | _ -> let rec make_params n = if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in @@ -510,12 +526,14 @@ let rec push_defaults loc bindings cases partial = [{c_lhs=pat; c_guard=None; c_rhs={exp_desc = Texp_function(l, pl,partial)} as exp}] -> let pl = push_defaults exp.exp_loc bindings pl partial in - [{c_lhs=pat; c_guard=None; c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}] + [{c_lhs=pat; c_guard=None; + c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}] | [{c_lhs=pat; c_guard=None; c_rhs={exp_attributes=[{txt="#default"},_]; exp_desc = Texp_let (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> - push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] partial + push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial | [case] -> let exp = List.fold_left @@ -536,10 +554,12 @@ let rec push_defaults loc bindings cases partial = val_attributes = []; Types.val_loc = Location.none; })}, - cases, partial) } + cases, [], partial) } in push_defaults loc bindings - [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; c_guard=None; c_rhs=exp}] Total + [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; + c_guard=None; c_rhs=exp}] + Total | _ -> cases @@ -694,6 +714,12 @@ and transl_exp0 e = k in wrap0 (Lprim(Praise k, [event_after arg1 targ])) + | (Ploc kind, []) -> + lam_of_loc kind e.exp_loc + | (Ploc kind, [arg1]) -> + let lam = lam_of_loc kind arg1.exp_loc in + Lprim(Pmakeblock(0, Immutable), lam :: argl) + | (Ploc _, _) -> assert false | (_, _) -> begin match (prim, argl) with | (Plazyforce, [a]) -> @@ -705,12 +731,8 @@ and transl_exp0 e = end | Texp_apply(funct, oargs) -> event_after e (transl_apply (transl_exp funct) oargs e.exp_loc) - | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) -> - Matching.for_multiple_match e.exp_loc - (transl_list argl) (transl_cases pat_expr_list) partial - | Texp_match(arg, pat_expr_list, partial) -> - Matching.for_function e.exp_loc None - (transl_exp arg) (transl_cases pat_expr_list) partial + | Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) -> + transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try(body, pat_expr_list) -> let id = name_pattern "exn" pat_expr_list in Ltrywith(transl_exp body, id, @@ -724,7 +746,7 @@ and transl_exp0 e = end | Texp_construct(_, cstr, args) -> let ll = transl_list args in - if cstr.cstr_inlined then begin match ll with + if cstr.cstr_inlined <> None then begin match ll with | [x] -> x | _ -> assert false end else begin match cstr.cstr_tag with @@ -736,10 +758,12 @@ and transl_exp0 e = with Not_constant -> Lprim(Pmakeblock(n, Immutable), ll) end - | Cstr_exception (path, _) -> - let slot = transl_path ~loc:e.exp_loc e.exp_env path in - if cstr.cstr_arity = 0 then slot - else Lprim(Pmakeblock(0, Immutable), slot :: ll) + | Cstr_extension(path, is_const) -> + if is_const then + transl_path e.exp_env path + else + Lprim(Pmakeblock(0, Immutable), + transl_path e.exp_env path :: ll) end | Texp_variant(l, arg) -> let tag = Btype.hash_variant l in @@ -764,7 +788,7 @@ and transl_exp0 e = match lbl.lbl_repres with Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos | Record_float -> Pfloatfield lbl.lbl_pos - | Record_exception _ -> Pfield (lbl.lbl_pos + 1) + | Record_extension -> Pfield (lbl.lbl_pos + 1) in Lprim(access, [transl_exp arg]) | Texp_setfield(arg, _, lbl, newval) -> @@ -773,8 +797,7 @@ and transl_exp0 e = Record_regular | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer newval) | Record_float -> Psetfloatfield lbl.lbl_pos - | Record_exception _ -> - Psetfield (lbl.lbl_pos + 1, maybe_pointer newval) + | Record_extension -> Psetfield (lbl.lbl_pos + 1, maybe_pointer newval) in Lprim(access, [transl_exp arg; transl_exp newval]) | Texp_array expr_list -> @@ -887,7 +910,6 @@ and transl_exp0 e = || has_base_type e Predef.path_exn || has_base_type e Predef.path_array || has_base_type e Predef.path_list - || has_base_type e Predef.path_format6 || has_base_type e Predef.path_option || has_base_type e Predef.path_nativeint || has_base_type e Predef.path_int32 @@ -1065,7 +1087,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = then begin (* Allocate new record with given fields (and remaining fields taken from init_expr if any *) - let lv = Array.create (Array.length all_labels) staticfail in + let lv = Array.make (Array.length all_labels) staticfail in let init_id = Ident.create "init" in begin match opt_init_expr with None -> () @@ -1074,7 +1096,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = let access = match all_labels.(i).lbl_repres with Record_regular | Record_inlined _ -> Pfield i - | Record_exception _ -> Pfield (i + 1) + | Record_extension -> Pfield (i + 1) | Record_float -> Pfloatfield i in lv.(i) <- Lprim(access, [Lvar init_id]) done @@ -1096,16 +1118,21 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = | Record_inlined tag -> Lconst(Const_block(tag, cl)) | Record_float -> Lconst(Const_float_array(List.map extract_float cl)) - | Record_exception _ -> + | Record_extension -> raise Not_constant with Not_constant -> match repres with Record_regular -> Lprim(Pmakeblock(0, mut), ll) | Record_inlined tag -> Lprim(Pmakeblock(tag, mut), ll) | Record_float -> Lprim(Pmakearray Pfloatarray, ll) - | Record_exception path -> + | Record_extension -> + let path = + match all_labels.(0).lbl_res.desc with + | Tconstr(p, _, _) -> p + | _ -> assert false + in let slot = transl_path env path in - Lprim(Pmakeblock(0, Immutable), slot :: ll) + Lprim(Pmakeblock(0, mut), slot :: ll) in begin match opt_init_expr with None -> lam @@ -1123,7 +1150,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = Record_regular | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer expr) | Record_float -> Psetfloatfield lbl.lbl_pos - | Record_exception _ -> Psetfield(lbl.lbl_pos + 1, maybe_pointer expr) + | Record_extension -> Psetfield(lbl.lbl_pos + 1, maybe_pointer expr) in Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in begin match opt_init_expr with @@ -1135,6 +1162,34 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = end end +and transl_match e arg pat_expr_list exn_pat_expr_list partial = + let id = name_pattern "exn" exn_pat_expr_list + and cases = transl_cases pat_expr_list + and exn_cases = transl_cases exn_pat_expr_list in + let static_catch body val_ids handler = + let static_exception_id = next_negative_raise_count () in + Lstaticcatch + (Ltrywith (Lstaticraise (static_exception_id, body), id, + Matching.for_trywith (Lvar id) exn_cases), + (static_exception_id, val_ids), + handler) + in + match arg, exn_cases with + | {exp_desc = Texp_tuple argl}, [] -> + Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial + | {exp_desc = Texp_tuple argl}, _ :: _ -> + let val_ids = List.map (fun _ -> name_pattern "val" []) argl in + let lvars = List.map (fun id -> Lvar id) val_ids in + static_catch (transl_list argl) val_ids + (Matching.for_multiple_match e.exp_loc lvars cases partial) + | arg, [] -> + Matching.for_function e.exp_loc None (transl_exp arg) cases partial + | arg, _ :: _ -> + let val_id = name_pattern "val" pat_expr_list in + static_catch [transl_exp arg] [val_id] + (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) + + (* Wrapper for class compilation *) (* diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 4b3141ad9..1f475565f 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -30,23 +30,50 @@ type error = exception Error of Location.t * error -(* Compile an exception definition *) +(* Keep track of the root path (from the root of the namespace to the + currently compiled module expression). Useful for naming extensions. *) + +let global_path glob = Some(Pident glob) +let functor_path path param = + match path with + None -> None + | Some p -> Some(Papply(p, Pident param)) +let field_path path field = + match path with + None -> None + | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) + +(* Compile type extensions *) let prim_set_oo_id = Pccall {Primitive.prim_name = "caml_set_oo_id"; prim_arity = 1; prim_alloc = false; prim_native_name = ""; prim_native_float = false} -let transl_exception path decl = +let transl_extension_constructor env path ext = let name = match path with - None -> Ident.name decl.cd_id + None -> Ident.name ext.ext_id | Some p -> Path.name p in - Lprim(prim_set_oo_id, - [Lprim(Pmakeblock(Obj.object_tag, Mutable), - [Lconst(Const_base(Const_string (name,None))); - Lconst(Const_base(Const_int 0))])]) + match ext.ext_kind with + Text_decl(args, ret) -> + Lprim(prim_set_oo_id, + [Lprim(Pmakeblock(Obj.object_tag, Mutable), + [Lconst(Const_base(Const_string (name,None))); + Lconst(Const_base(Const_int 0))])]) + | Text_rebind(path, lid) -> + transl_path ~loc:ext.ext_loc env path + +let transl_type_extension env rootpath tyext body = + List.fold_right + (fun ext body -> + let lam = + transl_extension_constructor env (field_path rootpath ext.ext_id) ext + in + Llet(Strict, ext.ext_id, lam, body)) + tyext.tyext_constructors + body (* Compile a coercion *) @@ -118,6 +145,19 @@ let rec compose_coercions c1 c2 = | (_, _) -> fatal_error "Translmod.compose_coercions" +(* +let apply_coercion a b c = + Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; + apply_coercion a b c + +let compose_coercions c1 c2 = + let c3 = compose_coercions c1 c2 in + let open Includemod in + Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." + print_coercion c1 print_coercion c2 print_coercion c2; + c3 +*) + (* Record the primitive declarations occuring in the module compiled *) let primitive_declarations = ref ([] : Primitive.description list) @@ -126,19 +166,6 @@ let record_primitive = function primitive_declarations := p :: !primitive_declarations | _ -> () -(* Keep track of the root path (from the root of the namespace to the - currently compiled module expression). Useful for naming exceptions. *) - -let global_path glob = Some(Pident glob) -let functor_path path param = - match path with - None -> None - | Some p -> Some(Papply(p, Pident param)) -let field_path path field = - match path with - None -> None - | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) - (* Utilities for compiling "module rec" definitions *) let mod_prim name = @@ -181,7 +208,7 @@ let init_shape modl = init_v :: init_shape_struct env rem | Sig_type(id, tdecl, _) :: rem -> init_shape_struct (Env.add_type ~check:false id tdecl env) rem - | Sig_exception(id, edecl) :: rem -> + | Sig_typext(id, ext, _) :: rem -> raise Not_found | Sig_module(id, md, _) :: rem -> init_shape_mod env md.md_type :: @@ -211,7 +238,7 @@ let reorder_rec_bindings bindings = and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in let fv = Array.map Lambda.free_variables rhs in let num_bindings = Array.length id in - let status = Array.create num_bindings Undefined in + let status = Array.make num_bindings Undefined in let res = ref [] in let rec emit_binding i = match status.(i) with @@ -275,14 +302,14 @@ let compile_recmodule compile_rhs bindings cont = (* Extract the list of "value" identifiers bound by a signature. "Value" identifiers are identifiers for signature components that - correspond to a run-time value: values, exceptions, modules, classes. + correspond to a run-time value: values, extensions, modules, classes. Note: manifest primitives do not correspond to a run-time value! *) let rec bound_value_identifiers = function [] -> [] | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem - | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem + | Sig_typext(id, ext, _) :: rem -> id :: bound_value_identifiers rem | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem @@ -363,12 +390,14 @@ and transl_structure fields cc rootpath = function transl_structure fields cc rootpath rem | Tstr_type(decls) -> transl_structure fields cc rootpath rem - | Tstr_exception decl -> - let id = decl.cd_id in - Llet(Strict, id, transl_exception (field_path rootpath id) decl, - transl_structure (id :: fields) cc rootpath rem) - | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) -> - Llet(Strict, id, transl_path ~loc item.str_env path, + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + transl_type_extension item.str_env rootpath tyext + (transl_structure (List.rev_append ids fields) cc rootpath rem) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + Llet(Strict, id, transl_extension_constructor item.str_env path ext, transl_structure (id :: fields) cc rootpath rem) | Tstr_module mb -> let id = mb.mb_id in @@ -392,9 +421,10 @@ and transl_structure fields cc rootpath = function let cl = ci.ci_expr in (id, transl_class ids id meths cl vf )) cl_list, - transl_structure (List.rev ids @ fields) cc rootpath rem) - | Tstr_include(modl, sg, _) -> - let ids = bound_value_identifiers sg in + transl_structure (List.rev_append ids fields) cc rootpath rem) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec rebind_idents pos newfields = function [] -> @@ -444,8 +474,10 @@ let rec defined_idents = function let_bound_idents pat_expr_list @ defined_idents rem | Tstr_primitive desc -> defined_idents rem | Tstr_type decls -> defined_idents rem - | Tstr_exception decl -> decl.cd_id :: defined_idents rem - | Tstr_exn_rebind(id, _, path, _, _) -> id :: defined_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ defined_idents rem + | Tstr_exception ext -> ext.ext_id :: defined_idents rem | Tstr_module mb -> mb.mb_id :: defined_idents rem | Tstr_recmodule decls -> List.map (fun mb -> mb.mb_id) decls @ defined_idents rem @@ -454,7 +486,8 @@ let rec defined_idents = function | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem | Tstr_class_type cl_list -> defined_idents rem - | Tstr_include(modl, sg, _) -> bound_value_identifiers sg @ defined_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ defined_idents rem | Tstr_attribute _ -> defined_idents rem (* second level idents (module M = struct ... let id = ... end), @@ -467,14 +500,14 @@ let rec more_idents = function | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem | Tstr_primitive _ -> more_idents rem | Tstr_type decls -> more_idents rem + | Tstr_typext tyext -> more_idents rem | Tstr_exception _ -> more_idents rem - | Tstr_exn_rebind(id, _, path, _, _) -> more_idents rem | Tstr_recmodule decls -> more_idents rem | Tstr_modtype _ -> more_idents rem | Tstr_open _ -> more_idents rem | Tstr_class cl_list -> more_idents rem | Tstr_class_type cl_list -> more_idents rem - | Tstr_include(modl, _, _) -> more_idents rem + | Tstr_include _ -> more_idents rem | Tstr_module {mb_expr={mod_desc = Tmod_structure str}} -> all_idents str.str_items @ more_idents rem | Tstr_module _ -> more_idents rem @@ -489,8 +522,10 @@ and all_idents = function let_bound_idents pat_expr_list @ all_idents rem | Tstr_primitive _ -> all_idents rem | Tstr_type decls -> all_idents rem - | Tstr_exception decl -> decl.cd_id :: all_idents rem - | Tstr_exn_rebind(id, _, path, _, _) -> id :: all_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ all_idents rem + | Tstr_exception ext -> ext.ext_id :: all_idents rem | Tstr_recmodule decls -> List.map (fun mb -> mb.mb_id) decls @ all_idents rem | Tstr_modtype _ -> all_idents rem @@ -498,7 +533,8 @@ and all_idents = function | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem | Tstr_class_type cl_list -> all_idents rem - | Tstr_include(modl, sg, _) -> bound_value_identifiers sg @ all_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ all_idents rem | Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} -> mb_id :: all_idents str.str_items @ all_idents rem | Tstr_module mb -> mb.mb_id :: all_idents rem @@ -545,14 +581,18 @@ let transl_store_structure glob map prims str = transl_store rootpath subst rem | Tstr_type(decls) -> transl_store rootpath subst rem - | Tstr_exception decl -> - let id = decl.cd_id in - let lam = transl_exception (field_path rootpath id) decl in - Lsequence(Llet(Strict, id, lam, store_ident id), - transl_store rootpath (add_ident false id subst) rem) - | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) -> - let lam = subst_lambda subst (transl_path ~loc item.str_env path) in - Lsequence(Llet(Strict, id, lam, store_ident id), + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let lam = + transl_type_extension item.str_env rootpath tyext (store_idents ids) + in + Lsequence(subst_lambda subst lam, + transl_store rootpath (add_idents false ids subst) rem) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + let lam = transl_extension_constructor item.str_env path ext in + Lsequence(Llet(Strict, id, subst_lambda subst lam, store_ident id), transl_store rootpath (add_ident false id subst) rem) | Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_structure str}} -> let lam = transl_store (field_path rootpath id) subst str.str_items in @@ -600,8 +640,9 @@ let transl_store_structure glob map prims str = store_idents ids) in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) - | Tstr_include(modl, sg, _attrs) -> - let ids = bound_value_identifiers sg in + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec store_idents pos = function [] -> transl_store rootpath (add_idents true ids subst) rem @@ -760,10 +801,19 @@ let transl_toplevel_item item = let idents = let_bound_idents pat_expr_list in transl_let rec_flag pat_expr_list (make_sequence toploop_setvalue_id idents) - | Tstr_exception decl -> - toploop_setvalue decl.cd_id (transl_exception None decl) - | Tstr_exn_rebind(id, _, path, {Location.loc=loc}, _) -> - toploop_setvalue id (transl_path ~loc item.str_env path) + | Tstr_typext(tyext) -> + let idents = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in + (* we need to use unique name in case of multiple + definitions of the same extension constructor in the toplevel *) + List.iter set_toplevel_unique_name idents; + transl_type_extension item.str_env None tyext + (make_sequence toploop_setvalue_id idents) + | Tstr_exception ext -> + set_toplevel_unique_name ext.ext_id; + toploop_setvalue ext.ext_id + (transl_extension_constructor item.str_env None ext) | Tstr_module {mb_id=id; mb_expr=modl} -> (* we need to use the unique name for the module because of issues with "open" (PR#1672) *) @@ -790,8 +840,9 @@ let transl_toplevel_item item = make_sequence (fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class) cl_list) - | Tstr_include(modl, sg, _attrs) -> - let ids = bound_value_identifiers sg in + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec set_idents pos = function [] -> @@ -868,7 +919,7 @@ let transl_store_package component_names target_name coercion = [Lprim(Pgetglobal target_name, []); Lprim(Pfield pos, [Lvar blk])])) 0 pos_cc_list)) - (* + (* (* ignore id_pos_list as the ids are already bound *) let id = Array.of_list component_names in (List.length pos_cc_list, @@ -900,3 +951,9 @@ let () = | _ -> None ) + +let reset () = + primitive_declarations := []; + transl_store_subst := Ident.empty; + toploop_ident.Ident.flags <- 0; + aliased_idents := Ident.empty diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 8e5005546..1d84aaabd 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -37,3 +37,5 @@ type error = exception Error of Location.t * error val report_error: Format.formatter -> error -> unit + +val reset: unit -> unit diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 7f0d8577e..02731ec68 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -162,3 +162,14 @@ let oo_wrap env req f x = wrapping := false; top_env := Env.empty; raise exn + +let reset () = + Hashtbl.clear consts; + cache_required := false; + method_cache := lambda_unit; + method_count := 0; + method_table := []; + wrapping := false; + top_env := Env.empty; + classes := []; + method_ids := IdentSet.empty diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index 55c163433..a44ac683f 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -26,3 +26,5 @@ val method_ids: IdentSet.t ref (* reset when starting a new wrapper *) val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda val oo_add_class: Ident.t -> Env.t * bool + +val reset: unit -> unit diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index c96e32b66..eb8c9435e 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -34,7 +34,7 @@ let maybe_pointer exp = match Env.find_type p exp.exp_env with | {type_kind = Type_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> - List.exists (fun c -> c.Types.cd_args <> []) cstrs + List.exists (fun c -> c.Types.cd_args <> Cstr_tuple []) cstrs | _ -> true with Not_found -> true (* This can happen due to e.g. missing -I options, @@ -64,7 +64,8 @@ let array_element_kind env ty = {type_kind = Type_abstract} -> Pgenarray | {type_kind = Type_variant cstrs} - when List.for_all (fun c -> c.Types.cd_args = []) cstrs -> + when List.for_all (fun c -> c.Types.cd_args = Cstr_tuple []) + cstrs -> Pintarray | {type_kind = _} -> Paddrarray |