summaryrefslogtreecommitdiff
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/codegen.ml444
-rw-r--r--bytecomp/codegen.mli8
-rw-r--r--bytecomp/librarian.ml62
-rw-r--r--bytecomp/librarian.mli18
-rw-r--r--bytecomp/linker.ml262
-rw-r--r--bytecomp/linker.mli16
6 files changed, 0 insertions, 810 deletions
diff --git a/bytecomp/codegen.ml b/bytecomp/codegen.ml
deleted file mode 100644
index 0f2a88f1b1..0000000000
--- a/bytecomp/codegen.ml
+++ /dev/null
@@ -1,444 +0,0 @@
-(* codegen.ml : translation of lambda terms to lists of instructions. *)
-
-open Misc
-open Asttypes
-open Lambda
-open Instruct
-
-(**** Label generation ****)
-
-let label_counter = ref 0
-
-let new_label () =
- incr label_counter; !label_counter
-
-(**** Structure of the compilation environment. ****)
-
-type compilation_env =
- { ce_stack: int Ident.tbl; (* Positions of variables in the stack *)
- ce_heap: int Ident.tbl } (* Structure of the heap-allocated env *)
-
-(* The ce_stack component gives locations of variables residing
- in the stack. The locations are offsets w.r.t. the origin of the
- stack frame.
- The ce_heap component gives the positions of variables residing in the
- heap-allocated environment. *)
-
-let empty_env =
- { ce_stack = Ident.empty; ce_heap = Ident.empty }
-
-(* Add a stack-allocated variable *)
-
-let add_var id pos env =
- { ce_stack = Ident.add id pos env.ce_stack;
- ce_heap = env.ce_heap }
-
-(**** Examination of the continuation ****)
-
-(* Return a label to the beginning of the given continuation.
- If the sequence starts with a branch, use the target of that branch
- as the label, thus avoiding a jump to a jump. *)
-
-let label_code = function
- Kbranch lbl :: _ as cont -> (lbl, cont)
- | Klabel lbl :: _ as cont -> (lbl, cont)
- | cont -> let lbl = new_label() in (lbl, Klabel lbl :: cont)
-
-(* Return a branch to the continuation. That is, an instruction that,
- when executed, branches to the continuation or performs what the
- continuation performs. We avoid generating branches to branches and
- branches to returns. *)
-
-let make_branch cont =
- match cont with
- (Kbranch _ as branch) :: _ -> (branch, cont)
- | (Kreturn _ as return) :: _ -> (return, cont)
- | Kraise :: _ -> (Kraise, cont)
- | Klabel lbl :: _ -> (Kbranch lbl, cont)
- | _ -> let lbl = new_label() in (Kbranch lbl, Klabel lbl :: cont)
-
-(* Discard all instructions up to the next label.
- This function is to be applied to the continuation before adding a
- non-terminating instruction (branch, raise, return) in front of it. *)
-
-let rec discard_dead_code = function
- [] -> []
- | (Klabel _ | Krestart) :: _ as cont -> cont
- | _ :: cont -> discard_dead_code cont
-
-(* Check if we're in tailcall position *)
-
-let rec is_tailcall = function
- Kreturn _ :: _ -> true
- | Klabel _ :: c -> is_tailcall c
- | _ -> false
-
-(* Add a Kpop N instruction in front of a continuation *)
-
-let rec add_pop n cont =
- if n = 0 then cont else
- match cont with
- Kpop m :: cont -> add_pop (n + m) cont
- | Kreturn m :: cont -> Kreturn(n + m) :: cont
- | Kraise :: _ -> cont
- | _ -> Kpop n :: cont
-
-(* Add the constant "unit" in front of a continuation *)
-
-let add_const_unit = function
- (Kacc _ | Kconst _ | Kgetglobal _ | Kpush_retaddr _) :: _ as cont -> cont
- | cont -> Kconst const_unit :: cont
-
-(**** Compilation of a lambda expression ****)
-
-(* The label to which Lstaticfail branches, and the stack size at that point.*)
-
-let lbl_staticfail = ref 0
-and sz_staticfail = ref 0
-
-(* Function bodies that remain to be compiled *)
-
-let functions_to_compile =
- (Stack.new () : (Ident.t * lambda * label * Ident.t list) Stack.t)
-
-(* Compile an expression.
- The value of the expression is left in the accumulator.
- env = compilation environment
- exp = the lambda expression to compile
- sz = current size of the stack frame
- cont = list of instructions to execute afterwards
- Result = list of instructions that evaluate exp, then perform cont. *)
-
-open Format
-
-let rec comp_expr env exp sz cont =
- match exp with
- Lvar id ->
- begin try
- let pos = Ident.find_same id env.ce_stack in
- Kacc(sz - pos) :: cont
- with Not_found ->
- try
- let pos = Ident.find_same id env.ce_heap in
- Kenvacc(pos) :: cont
- with Not_found ->
- Ident.print id; print_newline();
- fatal_error "Codegen.comp_expr: var"
- end
- | Lconst cst ->
- Kconst cst :: cont
- | Lapply(func, args) ->
- let nargs = List.length args in
- if is_tailcall cont then
- comp_args env args sz
- (Kpush :: comp_expr env func (sz + nargs)
- (Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
- else
- if nargs < 4 then
- comp_args env args sz
- (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
- else begin
- let (lbl, cont1) = label_code cont in
- Kpush_retaddr lbl ::
- comp_args env args (sz + 3)
- (Kpush :: comp_expr env func (sz + 3 + nargs)
- (Kapply nargs :: cont1))
- end
- | Lfunction(param, body) ->
- let lbl = new_label() in
- let fv = free_variables exp in
- Stack.push (param, body, lbl, fv) functions_to_compile;
- comp_args env (List.map (fun n -> Lvar n) fv) sz
- (Kclosure(lbl, List.length fv) :: cont)
- | Llet(id, arg, body) ->
- comp_expr env arg sz
- (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1)
- (add_pop 1 cont))
- | Lletrec(([id, Lfunction(param, funct_body), _] as decl), let_body) ->
- let lbl = new_label() in
- let fv = free_variables (Lletrec(decl, lambda_unit)) in
- Stack.push (param, funct_body, lbl, id :: fv) functions_to_compile;
- comp_args env (List.map (fun n -> Lvar n) fv) sz
- (Kclosurerec(lbl, List.length fv) :: Kpush ::
- (comp_expr (add_var id (sz+1) env) let_body (sz+1)
- (add_pop 1 cont)))
- | Lletrec(decl, body) ->
- let ndecl = List.length decl in
- let rec comp_decl new_env sz i = function
- [] ->
- comp_expr new_env body sz (add_pop ndecl cont)
- | (id, exp, blocksize) :: rem ->
- comp_expr new_env exp sz
- (Kpush :: Kacc i :: Kupdate blocksize ::
- comp_decl new_env sz (i-1) rem) in
- let rec comp_init new_env sz = function
- [] ->
- comp_decl new_env sz ndecl decl
- | (id, exp, blocksize) :: rem ->
- Kdummy blocksize :: Kpush ::
- comp_init (add_var id (sz+1) new_env) (sz+1) rem in
- comp_init env sz decl
- | Lprim(Pidentity, [arg]) ->
- comp_expr env arg sz cont
- | Lprim(Pnot, [arg]) ->
- let newcont =
- match cont with
- Kbranchif lbl :: cont1 -> Kbranchifnot lbl :: cont1
- | Kbranchifnot lbl :: cont1 -> Kbranchif lbl :: cont1
- | _ -> Kboolnot :: cont in
- comp_expr env arg sz newcont
- | Lprim(Psequand, [exp1; exp2]) ->
- begin match cont with
- Kbranchifnot lbl :: _ ->
- comp_expr env exp1 sz (Kbranchifnot lbl ::
- comp_expr env exp2 sz cont)
- | Kbranchif lbl :: cont1 ->
- let (lbl2, cont2) = label_code cont1 in
- comp_expr env exp1 sz (Kbranchifnot lbl2 ::
- comp_expr env exp2 sz (Kbranchif lbl :: cont2))
- | _ ->
- let (lbl, cont1) = label_code cont in
- comp_expr env exp1 sz (Kstrictbranchifnot lbl ::
- comp_expr env exp2 sz cont1)
- end
- | Lprim(Psequor, [exp1; exp2]) ->
- begin match cont with
- Kbranchif lbl :: _ ->
- comp_expr env exp1 sz (Kbranchif lbl ::
- comp_expr env exp2 sz cont)
- | Kbranchifnot lbl :: cont1 ->
- let (lbl2, cont2) = label_code cont1 in
- comp_expr env exp1 sz (Kbranchif lbl2 ::
- comp_expr env exp2 sz (Kbranchifnot lbl :: cont2))
- | _ ->
- let (lbl, cont1) = label_code cont in
- comp_expr env exp1 sz (Kstrictbranchif lbl ::
- comp_expr env exp2 sz cont1)
- end
- | Lprim(Praise, [arg]) ->
- comp_expr env arg sz (Kraise :: discard_dead_code cont)
- | Lprim((Paddint | Psubint as prim), [arg; Lconst(Const_base(Const_int n))])
- when n >= immed_min & n <= immed_max ->
- let ofs = if prim == Paddint then n else -n in
- comp_expr env arg sz (Koffsetint ofs :: cont)
- | Lprim(p, args) ->
- let instr =
- match p with
- Pgetglobal id -> Kgetglobal id
- | Psetglobal id -> Ksetglobal id
- | Pintcomp cmp -> Kintcomp cmp
- | Pmakeblock tag -> Kmakeblock(List.length args, tag)
- | Pfield n -> Kgetfield n
- | Psetfield n -> Ksetfield n
- | Pccall(name, n) -> Kccall(name, n)
- | Pnegint -> Knegint
- | Paddint -> Kaddint
- | Psubint -> Ksubint
- | Pmulint -> Kmulint
- | Pdivint -> Kdivint
- | Pmodint -> Kmodint
- | Pandint -> Kandint
- | Porint -> Korint
- | Pxorint -> Kxorint
- | Plslint -> Klslint
- | Plsrint -> Klsrint
- | Pasrint -> Kasrint
- | Poffsetint n -> Koffsetint n
- | Poffsetref n -> Koffsetref n
- | Pnegfloat -> Kccall("neg_float", 1)
- | Paddfloat -> Kccall("add_float", 2)
- | Psubfloat -> Kccall("sub_float", 2)
- | Pmulfloat -> Kccall("mul_float", 2)
- | Pdivfloat -> Kccall("div_float", 2)
- | Pfloatcomp Ceq -> Kccall("eq_float", 2)
- | Pfloatcomp Cneq -> Kccall("neq_float", 2)
- | Pfloatcomp Clt -> Kccall("lt_float", 2)
- | Pfloatcomp Cgt -> Kccall("gt_float", 2)
- | Pfloatcomp Cle -> Kccall("le_float", 2)
- | Pfloatcomp Cge -> Kccall("ge_float", 2)
- | Pgetstringchar -> Kgetstringchar
- | Psetstringchar -> Ksetstringchar
- | Pvectlength -> Kvectlength
- | Pgetvectitem -> Kgetvectitem
- | Psetvectitem -> Ksetvectitem
- | Ptranslate tbl -> Ktranslate tbl
- | _ -> fatal_error "Codegen.comp_expr: prim" in
- comp_args env args sz (instr :: cont)
- | Lcatch(body, Lstaticfail) ->
- comp_expr env body sz cont
- | Lcatch(body, handler) ->
- let (branch1, cont1) = make_branch cont in
- let (lbl_handler, cont2) = label_code (comp_expr env handler sz cont1) in
- let saved_lbl_staticfail = !lbl_staticfail
- and saved_sz_staticfail = !sz_staticfail in
- lbl_staticfail := lbl_handler;
- sz_staticfail := sz;
- let cont3 = comp_expr env body sz (branch1 :: cont2) in
- lbl_staticfail := saved_lbl_staticfail;
- sz_staticfail := saved_sz_staticfail;
- cont3
- | Lstaticfail ->
- add_pop (sz - !sz_staticfail)
- (Kbranch !lbl_staticfail :: discard_dead_code cont)
- | 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))
- | Lifthenelse(cond, ifso, ifnot) ->
- comp_binary_test env cond ifso ifnot sz cont
- | Lsequence(exp1, exp2) ->
- comp_expr env exp1 sz (comp_expr env exp2 sz cont)
- | Lwhile(cond, body) ->
- let lbl_loop = new_label() in
- let lbl_test = new_label() in
- Kbranch lbl_test :: Klabel lbl_loop :: Kcheck_signals ::
- comp_expr env body sz
- (Klabel lbl_test ::
- comp_expr env cond sz (Kbranchif lbl_loop :: add_const_unit cont))
- | Lfor(param, start, stop, dir, body) ->
- let lbl_loop = new_label() in
- let lbl_test = new_label() in
- let offset = match dir with Upto -> 1 | Downto -> -1 in
- let comp = match dir with Upto -> Cle | Downto -> Cge in
- comp_expr env start sz
- (Kpush :: comp_expr env stop (sz+1)
- (Kpush :: Kbranch lbl_test ::
- Klabel lbl_loop :: Kcheck_signals ::
- comp_expr (add_var param (sz+1) env) body (sz+2)
- (Kacc 1 :: Koffsetint offset :: Kassign 1 ::
- Klabel lbl_test ::
- Kacc 0 :: Kpush :: Kacc 2 :: Kintcomp comp ::
- Kbranchif lbl_loop ::
- add_const_unit (add_pop 2 cont))))
- | Lswitch(arg, num_consts, consts, num_blocks, blocks) ->
- (* To ensure stack balancing, we must have either sz = !sz_staticfail
- or none of the actv.(i) contains an unguarded Lstaticfail. *)
- let (branch, cont1) = make_branch cont in
- let c = ref (discard_dead_code cont1) in
- let act_consts = Array.new num_consts Lstaticfail in
- List.iter (fun (n, act) -> act_consts.(n) <- act) consts;
- let act_blocks = Array.new num_blocks Lstaticfail in
- List.iter (fun (n, act) -> act_blocks.(n) <- act) blocks;
- let lbl_consts = Array.new num_consts 0 in
- let lbl_blocks = Array.new num_blocks 0 in
- for i = num_blocks - 1 downto 0 do
- let (lbl, c1) =
- label_code(comp_expr env act_blocks.(i) sz (branch :: !c)) in
- lbl_blocks.(i) <- lbl;
- c := discard_dead_code c1
- done;
- for i = num_consts - 1 downto 0 do
- let (lbl, c1) =
- label_code(comp_expr env act_consts.(i) sz (branch :: !c)) in
- lbl_consts.(i) <- lbl;
- c := discard_dead_code c1
- done;
- comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c)
- | Lshared(expr, lblref) ->
- begin match !lblref with
- None ->
- let (lbl, cont1) = label_code(comp_expr env expr sz cont) in
- lblref := Some lbl;
- cont1
- | Some lbl ->
- Kbranch lbl :: discard_dead_code cont
- end
-
-(* Compile a list of arguments [e1; ...; eN] to a primitive operation.
- The values of eN ... e2 are pushed on the stack, e2 at top of stack,
- then e3, then ... The value of e1 is left in the accumulator. *)
-
-and comp_args env argl sz cont =
- comp_expr_list env (List.rev argl) sz cont
-
-and comp_expr_list env exprl sz cont =
- match exprl with
- [] -> cont
- | [exp] -> comp_expr env exp sz cont
- | exp :: rem ->
- comp_expr env exp sz (Kpush :: comp_expr_list env rem (sz+1) cont)
-
-(* Compile an if-then-else test. *)
-
-and comp_binary_test env cond ifso ifnot sz cont =
- let cont_cond =
- if ifnot = Lconst const_unit then begin
- let (lbl_end, cont1) = label_code cont in
- Kbranchifnot lbl_end :: comp_expr env ifso sz cont1
- end else
- if ifso = Lstaticfail & sz = !sz_staticfail then
- Kbranchif !lbl_staticfail :: comp_expr env ifnot sz cont
- else
- if ifnot = Lstaticfail & sz = !sz_staticfail then
- Kbranchifnot !lbl_staticfail :: comp_expr env ifso sz cont
- else begin
- let (branch_end, cont1) = make_branch cont in
- let (lbl_not, cont2) = label_code(comp_expr env ifnot sz cont1) in
- Kbranchifnot lbl_not :: comp_expr env ifso sz (branch_end :: cont2)
- end in
- comp_expr env cond sz cont_cond
-
-(**** Compilation of functions ****)
-
-let comp_function (param, body, entry_lbl, free_vars) cont =
- (* Uncurry the function body *)
- let rec uncurry = function
- Lfunction(param, body) ->
- let (params, final) = uncurry body in (param :: params, final)
- | Lshared(exp, lblref) ->
- uncurry exp
- | exp ->
- ([], exp) in
- let (params, fun_body) =
- uncurry (Lfunction(param, body)) in
- let arity = List.length params in
- let rec pos_args pos delta = function
- [] -> Ident.empty
- | id :: rem -> Ident.add id pos (pos_args (pos+delta) delta rem) in
- let env =
- { ce_stack = pos_args arity (-1) params;
- ce_heap = pos_args 0 1 free_vars } in
- let cont1 =
- comp_expr env fun_body arity (Kreturn arity :: cont) in
- if arity > 1 then
- Krestart :: Klabel entry_lbl :: Kgrab(arity - 1) :: cont1
- else
- Klabel entry_lbl :: cont1
-
-let comp_remainder cont =
- let c = ref cont in
- begin try
- while true do
- c := comp_function (Stack.pop functions_to_compile) !c
- done
- with Stack.Empty ->
- ()
- end;
- !c
-
-(**** Compilation of a lambda phrase ****)
-
-let compile_implementation expr =
- Stack.clear functions_to_compile;
- label_counter := 0;
- lbl_staticfail := 0;
- sz_staticfail := 0;
- let init_code = comp_expr empty_env expr 0 [] in
- if Stack.length functions_to_compile > 0 then begin
- let lbl_init = new_label() in
- Kbranch lbl_init :: comp_remainder (Klabel lbl_init :: init_code)
- end else
- init_code
-
-let compile_phrase expr =
- Stack.clear functions_to_compile;
- label_counter := 0;
- lbl_staticfail := 0;
- sz_staticfail := 0;
- let init_code = comp_expr empty_env expr 0 [Kstop] in
- let fun_code = comp_remainder [] in
- (init_code, fun_code)
-
diff --git a/bytecomp/codegen.mli b/bytecomp/codegen.mli
deleted file mode 100644
index 97cb863e37..0000000000
--- a/bytecomp/codegen.mli
+++ /dev/null
@@ -1,8 +0,0 @@
-(* Generation of bytecode from lambda terms *)
-
-open Lambda
-open Instruct
-
-val compile_implementation: lambda -> instruction list
-val compile_phrase: lambda -> instruction list * instruction list
-
diff --git a/bytecomp/librarian.ml b/bytecomp/librarian.ml
deleted file mode 100644
index 156896e1ae..0000000000
--- a/bytecomp/librarian.ml
+++ /dev/null
@@ -1,62 +0,0 @@
-(* Build libraries of .cmo files *)
-
-open Misc
-open Config
-open Emitcode
-
-type error =
- File_not_found of string
- | Not_an_object_file of string
-
-exception Error of error
-
-let copy_object_file outchan toc name =
- let file_name =
- try
- find_in_path !load_path name
- with Not_found ->
- raise(Error(File_not_found name)) in
- let ic = open_in_bin file_name in
- try
- let buffer = String.create (String.length cmo_magic_number) in
- really_input ic buffer 0 (String.length cmo_magic_number);
- if buffer <> cmo_magic_number then
- raise(Error(Not_an_object_file file_name));
- let compunit_pos = input_binary_int ic in
- seek_in ic compunit_pos;
- let compunit = (input_value ic : compilation_unit) in
- seek_in ic compunit.cu_pos;
- compunit.cu_pos <- pos_out outchan;
- copy_file_chunk ic outchan compunit.cu_codesize;
- close_in ic;
- compunit :: toc
- with x ->
- close_in ic;
- raise x
-
-let create_archive file_list lib_name =
- let outchan = open_out_bin lib_name in
- try
- output_string outchan cma_magic_number;
- let ofs_pos_toc = pos_out outchan in
- output_binary_int outchan 0;
- let toc = List.fold_left (copy_object_file outchan) [] file_list in
- let pos_toc = pos_out outchan in
- output_value outchan toc;
- seek_out outchan ofs_pos_toc;
- output_binary_int outchan pos_toc;
- close_out outchan
- with x ->
- close_out outchan;
- remove_file lib_name;
- raise x
-
-open Format
-
-let report_error = function
- File_not_found name ->
- print_string "Cannot find file "; print_string name
- | Not_an_object_file name ->
- print_string "The file "; print_string name;
- print_string " is not a bytecode object file"
-
diff --git a/bytecomp/librarian.mli b/bytecomp/librarian.mli
deleted file mode 100644
index ee9c9f378e..0000000000
--- a/bytecomp/librarian.mli
+++ /dev/null
@@ -1,18 +0,0 @@
-(* Build libraries of .cmo files *)
-
-(* Format of a library file:
- Obj.magic number (Config.cma_magic_number)
- absolute offset of content table
- blocks of relocatable bytecode
- content table = list of compilation units
-*)
-
-val create_archive: string list -> string -> unit
-
-type error =
- File_not_found of string
- | Not_an_object_file of string
-
-exception Error of error
-
-val report_error: error -> unit
diff --git a/bytecomp/linker.ml b/bytecomp/linker.ml
deleted file mode 100644
index a883491f27..0000000000
--- a/bytecomp/linker.ml
+++ /dev/null
@@ -1,262 +0,0 @@
-(* Link a set of .cmo files and produce a bytecode executable. *)
-
-open Sys
-open Misc
-open Config
-open Emitcode
-
-type error =
- File_not_found of string
- | Not_an_object_file of string
- | Symbol_error of string * Symtable.error
- | Inconsistent_import of string * string * string
- | Custom_runtime
-
-exception Error of error
-
-type link_action =
- Link_object of string * compilation_unit
- (* Name of .cmo file and descriptor of the unit *)
- | Link_archive of string * compilation_unit list
- (* Name of .cma file and descriptors of the units to be linked. *)
-
-(* First pass: determine which units are needed *)
-
-module IdentSet =
- Set.Make(struct
- type t = Ident.t
- let compare = compare
- end)
-
-let missing_globals = ref IdentSet.empty
-
-let is_required (rel, pos) =
- match rel with
- Reloc_setglobal id ->
- IdentSet.mem id !missing_globals
- | _ -> false
-
-let add_required (rel, pos) =
- match rel with
- Reloc_getglobal id ->
- missing_globals := IdentSet.add id !missing_globals
- | _ -> ()
-
-let remove_required (rel, pos) =
- match rel with
- Reloc_setglobal id ->
- missing_globals := IdentSet.remove id !missing_globals
- | _ -> ()
-
-let scan_file tolink obj_name =
- let file_name =
- try
- find_in_path !load_path obj_name
- with Not_found ->
- raise(Error(File_not_found obj_name)) in
- let ic = open_in_bin file_name in
- try
- let buffer = String.create (String.length cmo_magic_number) in
- really_input ic buffer 0 (String.length cmo_magic_number);
- 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
- requires. *)
- let compunit_pos = input_binary_int ic in (* Go to descriptor *)
- seek_in ic compunit_pos;
- let compunit = (input_value ic : compilation_unit) in
- List.iter add_required compunit.cu_reloc;
- Link_object(file_name, compunit) :: tolink
- end
- else if buffer = cma_magic_number then begin
- (* This is an archive file. Each unit contained in it will be linked
- in only if needed. *)
- let pos_toc = input_binary_int ic in (* Go to table of contents *)
- seek_in ic pos_toc;
- let toc = (input_value ic : compilation_unit list) in
- let required =
- List.fold_left
- (fun reqd compunit ->
- if List.exists is_required compunit.cu_reloc
- or !Clflags.link_everything
- then begin
- List.iter remove_required compunit.cu_reloc;
- List.iter add_required compunit.cu_reloc;
- compunit :: reqd
- end else
- reqd)
- [] toc in
- Link_archive(file_name, required) :: tolink
- end
- else raise(Error(Not_an_object_file file_name))
- with x ->
- close_in ic; raise x
-
-(* Second pass: link in the required units *)
-
-(* Consistency check between interfaces *)
-
-let crc_interfaces = (Hashtbl.new 17 : (string, string * int) Hashtbl.t)
-
-let check_consistency file_name cu =
- List.iter
- (fun (name, crc) ->
- try
- let (auth_name, auth_crc) = Hashtbl.find crc_interfaces name in
- if crc <> auth_crc then
- raise(Error(Inconsistent_import(name, file_name, auth_name)))
- with Not_found ->
- Hashtbl.add crc_interfaces name (file_name, crc))
- cu.cu_interfaces
-
-(* Link in a compilation unit *)
-
-let link_compunit outchan inchan file_name compunit =
- check_consistency file_name compunit;
- seek_in inchan compunit.cu_pos;
- let code_block = String.create compunit.cu_codesize in
- really_input inchan code_block 0 compunit.cu_codesize;
- Symtable.patch_object code_block compunit.cu_reloc;
- output outchan code_block 0 compunit.cu_codesize
-
-(* Link in a .cmo file *)
-
-let link_object outchan file_name compunit =
- let inchan = open_in_bin file_name in
- try
- link_compunit outchan inchan file_name compunit;
- close_in inchan
- with
- Symtable.Error msg ->
- close_in inchan; raise(Error(Symbol_error(file_name, msg)))
- | x ->
- close_in inchan; raise x
-
-(* Link in a .cma file *)
-
-let link_archive outchan file_name units_required =
- let inchan = open_in_bin file_name in
- try
- List.iter (link_compunit outchan inchan file_name) units_required;
- close_in inchan
- with
- Symtable.Error msg ->
- close_in inchan; raise(Error(Symbol_error(file_name, msg)))
- | x ->
- close_in inchan; raise x
-
-(* Link in a .cmo or .cma file *)
-
-let link_file outchan = function
- Link_object(file_name, unit) -> link_object outchan file_name unit
- | Link_archive(file_name, units) -> link_archive outchan file_name units
-
-(* Create a bytecode executable file *)
-
-let link_bytecode objfiles exec_name copy_header =
- let objfiles = "stdlib.cma" :: objfiles in
- let tolink =
- List.fold_left scan_file [] (List.rev objfiles) in
- let outchan =
- open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] 0o777
- exec_name in
- try
- (* Copy the header *)
- if copy_header then begin
- try
- let inchan = open_in_bin (find_in_path !load_path "cslheader") in
- copy_file inchan outchan;
- close_in inchan
- with Not_found | Sys_error _ -> ()
- end;
- (* The bytecode *)
- let pos1 = pos_out outchan in
- Symtable.init();
- Hashtbl.clear crc_interfaces;
- List.iter (link_file outchan) tolink;
- (* 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 *)
- let pos2 = pos_out outchan in
- output_compact_value outchan (Symtable.initial_global_table());
- (* The List.map of global identifiers *)
- let pos3 = pos_out outchan in
- Symtable.output_global_map outchan;
- (* The trailer *)
- let pos4 = 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 0;
- output_string outchan exec_magic_number;
- close_out outchan
- with x ->
- close_out outchan;
- remove_file exec_name;
- raise x
-
-(* Main entry point (build a custom runtime if needed) *)
-
-let link objfiles =
- if not !Clflags.custom_runtime then
- link_bytecode objfiles !Clflags.exec_name true
- else begin
- let bytecode_name = temp_file "camlcode" "" in
- let prim_name = temp_file "camlprim" ".c" in
- try
- link_bytecode objfiles bytecode_name false;
- Symtable.output_primitives prim_name;
- if Sys.command
- (Printf.sprintf
- "%s -I%s -o %s %s %s -L%s %s -lcamlrun %s"
- Config.c_compiler
- Config.standard_library
- !Clflags.exec_name
- (String.concat " " (List.rev !Clflags.ccopts))
- prim_name
- Config.standard_library
- (String.concat " " (List.rev !Clflags.ccobjs))
- Config.c_libraries)
- <> 0
- or Sys.command ("strip " ^ !Clflags.exec_name) <> 0
- then raise(Error Custom_runtime);
- let oc =
- open_out_gen [Open_wronly; Open_append; Open_binary] 0
- !Clflags.exec_name in
- let ic = open_in_bin bytecode_name in
- copy_file ic oc;
- close_in ic;
- close_out oc;
- remove_file bytecode_name;
- remove_file prim_name
- with x ->
- remove_file bytecode_name;
- remove_file prim_name;
- raise x
- end
-
-(* Error report *)
-
-open Format
-
-let report_error = function
- File_not_found name ->
- print_string "Cannot find file "; print_string name
- | Not_an_object_file name ->
- print_string "The file "; print_string name;
- print_string " is not a bytecode object file"
- | Symbol_error(name, err) ->
- print_string "Error while linking "; print_string name; print_string ":";
- print_space();
- Symtable.report_error err
- | Inconsistent_import(intf, file1, file2) ->
- open_hvbox 0;
- print_string "Files "; print_string file1; print_string " and ";
- print_string file2; print_space();
- print_string "make inconsistent assumptions over interface ";
- print_string intf;
- close_box()
- | Custom_runtime ->
- print_string "Error while building custom runtime system"
-
diff --git a/bytecomp/linker.mli b/bytecomp/linker.mli
deleted file mode 100644
index b4c57e632c..0000000000
--- a/bytecomp/linker.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(* Link .cmo files and produce a bytecode executable. *)
-
-val link: string list -> unit
-
-val check_consistency: string -> Emitcode.compilation_unit -> unit
-
-type error =
- File_not_found of string
- | Not_an_object_file of string
- | Symbol_error of string * Symtable.error
- | Inconsistent_import of string * string * string
- | Custom_runtime
-
-exception Error of error
-
-val report_error: error -> unit
View Lorry Controller Status