diff options
| -rw-r--r-- | bytecomp/bytelink.ml | 16 | ||||
| -rw-r--r-- | bytecomp/symtable.ml | 16 | ||||
| -rw-r--r-- | bytecomp/symtable.mli | 3 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 14 |
4 files changed, 30 insertions, 19 deletions
diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 82124a408..1db87b828 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -236,21 +236,25 @@ let link_bytecode objfiles exec_name copy_header = (* The final STOP instruction *) output_byte outchan Opcodes.opSTOP; output_byte outchan 0; output_byte outchan 0; output_byte outchan 0; - (* The table of global data *) + (* The names of all primitives *) let pos2 = pos_out outchan in + Symtable.output_primitive_names outchan; + (* The table of global data *) + let pos3 = pos_out outchan in output_value outchan (Symtable.initial_global_table()); (* The map of global identifiers *) - let pos3 = pos_out outchan in + let pos4 = pos_out outchan in Symtable.output_global_map outchan; (* Debug info *) - let pos4 = pos_out outchan in + let pos5 = pos_out outchan in if !Clflags.debug then output_value outchan !debug_info; (* The trailer *) - let pos5 = pos_out outchan in + let pos6 = pos_out outchan in output_binary_int outchan (pos2 - pos1); output_binary_int outchan (pos3 - pos2); output_binary_int outchan (pos4 - pos3); output_binary_int outchan (pos5 - pos4); + output_binary_int outchan (pos6 - pos5); output_string outchan exec_magic_number; close_out outchan with x -> @@ -314,7 +318,7 @@ let link_bytecode_as_c objfiles outfile = output_data_string outchan (Obj.marshal(Obj.repr(Symtable.initial_global_table()))); (* The table of primitives *) - Symtable.output_primitives outchan; + Symtable.output_primitive_table outchan; (* The entry point *) output_string outchan "\n void caml_startup(argv) @@ -455,7 +459,7 @@ let link objfiles = try link_bytecode objfiles bytecode_name false; let poc = open_out prim_name in - Symtable.output_primitives poc; + Symtable.output_primitive_table poc; close_out poc; if build_custom_runtime prim_name !Clflags.exec_name <> 0 then raise(Error Custom_runtime); diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 6ba9278c6..fa281da16 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -82,11 +82,21 @@ let num_of_prim name = let require_primitive name = if name.[0] <> '%' then begin num_of_prim name; () end -open Printf - -let output_primitives outchan = +let all_primitives () = let prim = Array.create !c_prim_table.num_cnt "" in Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl; + prim + +let output_primitive_names outchan = + let prim = all_primitives() in + for i = 0 to Array.length prim - 1 do + output_string outchan prim.(i); output_char outchan '\000' + done + +open Printf + +let output_primitive_table outchan = + let prim = all_primitives() in for i = 0 to Array.length prim - 1 do fprintf outchan "extern long %s();\n" prim.(i) done; diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index 5850f2f3e..386fff4d1 100644 --- a/bytecomp/symtable.mli +++ b/bytecomp/symtable.mli @@ -22,7 +22,8 @@ val patch_object: string -> (reloc_info * int) list -> unit val require_primitive: string -> unit val initial_global_table: unit -> Obj.t array val output_global_map: out_channel -> unit -val output_primitives: out_channel -> unit +val output_primitive_names: out_channel -> unit +val output_primitive_table: out_channel -> unit (* Functions for the toplevel *) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index cf2b78820..4ab029478 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -212,8 +212,7 @@ let transl_prim prim args = stringcomp | _ -> gencomp - end, - false + end with Not_found -> try let p = Hashtbl.find primitives_table prim.prim_name in @@ -226,11 +225,9 @@ let transl_prim prim args = | (Parrayrefs Pgenarray, arg1 :: _) -> Parrayrefs(array_kind arg1) | (Parraysets Pgenarray, arg1 :: _) -> Parraysets(array_kind arg1) | _ -> p - end, - false + end with Not_found -> - Pccall prim, - true + Pccall prim (* Eta-expand a primitive without knowing the types of its arguments *) @@ -352,10 +349,9 @@ let rec transl_exp e = Lfunction(kind, params, body) | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args) when List.length args = p.prim_arity -> - let (prim, c_call) = transl_prim p args in + let prim = transl_prim p args in let lam = Lprim(prim, transl_list args) in - if c_call then event_after e lam - else lam + begin match prim with Pccall _ -> event_after e lam | _ -> lam end | Texp_apply(funct, args) -> let lam = match transl_exp funct with |