summaryrefslogtreecommitdiff
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/codegen.ml443
-rw-r--r--bytecomp/codegen.mli8
-rw-r--r--bytecomp/dectree.ml51
-rw-r--r--bytecomp/dectree.mli10
-rw-r--r--bytecomp/emitcode.ml285
-rw-r--r--bytecomp/emitcode.mli43
-rw-r--r--bytecomp/instruct.ml59
-rw-r--r--bytecomp/instruct.mli57
-rw-r--r--bytecomp/lambda.ml134
-rw-r--r--bytecomp/lambda.mli64
-rw-r--r--bytecomp/librarian.ml62
-rw-r--r--bytecomp/librarian.mli18
-rw-r--r--bytecomp/linker.ml262
-rw-r--r--bytecomp/linker.mli16
-rw-r--r--bytecomp/matching.ml262
-rw-r--r--bytecomp/matching.mli11
-rw-r--r--bytecomp/printinstr.ml103
-rw-r--r--bytecomp/printinstr.mli6
-rw-r--r--bytecomp/printlambda.ml195
-rw-r--r--bytecomp/printlambda.mli4
-rw-r--r--bytecomp/runtimedef.mli4
-rw-r--r--bytecomp/symtable.ml223
-rw-r--r--bytecomp/symtable.mli34
-rw-r--r--bytecomp/translcore.ml344
-rw-r--r--bytecomp/translcore.mli23
-rw-r--r--bytecomp/translmod.ml157
-rw-r--r--bytecomp/translmod.mli8
27 files changed, 0 insertions, 2886 deletions
diff --git a/bytecomp/codegen.ml b/bytecomp/codegen.ml
deleted file mode 100644
index fd70bd71cf..0000000000
--- a/bytecomp/codegen.ml
+++ /dev/null
@@ -1,443 +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 :: 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
- | Pupdate -> Kupdate
- | Pcomp cmp -> Kintcomp cmp
- | Pmakeblock tag -> Kmakeblock(List.length args, tag)
- | Ptagof -> Ktagof
- | 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
- | Pgetstringchar -> Kgetstringchar
- | Psetstringchar -> Ksetstringchar
- | Pvectlength -> Kvectlength
- | Pgetvectitem -> Kgetvectitem
- | Psetvectitem -> Ksetvectitem
- | _ -> 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 :: 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, lo, hi, casel) ->
- let numcases = List.length casel in
- let cont1 =
- if lo = 0 & numcases >= hi - 8 then (* Always true if hi <= 8... *)
- comp_direct_switch env hi casel sz cont
- else begin
- let (transl_table, actions) = Dectree.make_decision_tree casel in
- Ktranslate transl_table :: comp_switch env actions sz cont
- end in
- comp_expr env arg sz cont1
- | 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
-
-(* Compile a Lswitch directly, without breaking the array of cases into
- dense enough components *)
-
-and comp_direct_switch env range casel sz cont =
- let actv = Array.new range Lstaticfail in
- List.iter (fun (n, act) -> actv.(n) <- act) casel;
- comp_switch env actv sz cont
-
-(* Compile a switch instruction *)
-
-and comp_switch env actv sz cont =
- (* To ensure stack balancing, we must have either sz = !sz_staticfail
- or none of the actv.(i) contains an unguarded Lstaticfail. *)
- let lblv = Array.new (Array.length actv) !lbl_staticfail in
- let (branch, cont1) = make_branch cont in
- let c = ref (discard_dead_code cont1) in
- for i = Array.length actv - 1 downto 0 do
- let (lbl, c1) = label_code(comp_expr env actv.(i) sz (branch :: !c)) in
- lblv.(i) <- lbl;
- c := discard_dead_code c1
- done;
- Kswitch lblv :: !c
-
-(**** 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/dectree.ml b/bytecomp/dectree.ml
deleted file mode 100644
index 66e07611b1..0000000000
--- a/bytecomp/dectree.ml
+++ /dev/null
@@ -1,51 +0,0 @@
-open Lambda
-
-
-(* Input: a list of (key, action) pairs, where keys are integers. *)
-(* Output: a table of (low, high, offset) triples for Ktranslate
- an array of actions for Kswitch *)
-
-let make_decision_tree casei =
- (* Sort the cases by increasing keys *)
- let cases =
- Sort.list (fun (key1,act1) (key2,act2) -> key1 <= key2) casei in
- (* Extract the keys and the actions *)
- let keyv = Array.of_list (List.map fst cases)
- and actv = Array.of_list (List.map snd cases) in
- let n = Array.length keyv in
- (* Partition the set of keys keyv into maximal dense enough segments.
- A segment is dense enough if its span (max point - min point) is
- less than four times its size (number of points). *)
- let rec partition start =
- if start >= n then [] else
- let stop = ref (n-1) in
- while let span = keyv.(!stop) - keyv.(start) in
- span >= 256 or span > 4 * (!stop - start) do
- decr stop
- done;
- (* We've found a dense enough segment.
- In the worst case, !stop = start and the segment is a single point *)
- (* Record the segment and continue *)
- (start, !stop) :: partition (!stop + 1) in
- let part = partition 0 in
- (* Compute the length of the switch table.
- Slot 0 is reserved and always contains Lstaticfail. *)
- let switchl = ref 1 in
- List.iter
- (fun (start, stop) -> switchl := !switchl + keyv.(stop) - keyv.(start) + 1)
- part;
- (* Build the two tables *)
- let transl = Array.new (List.length part) (0, 0, 0)
- and switch = Array.new !switchl Lstaticfail in
- let tr_pos = ref 0
- and sw_ind = ref 1 in
- List.iter
- (fun (start, stop) ->
- transl.(!tr_pos) <- (keyv.(start), keyv.(stop), !sw_ind);
- for i = start to stop do
- switch.(!sw_ind + keyv.(i) - keyv.(start)) <- actv.(i)
- done;
- incr tr_pos;
- sw_ind := !sw_ind + keyv.(stop) - keyv.(start) + 1)
- part;
- (transl, switch)
diff --git a/bytecomp/dectree.mli b/bytecomp/dectree.mli
deleted file mode 100644
index a22ef611ce..0000000000
--- a/bytecomp/dectree.mli
+++ /dev/null
@@ -1,10 +0,0 @@
-(* Transformation of N-way integer branches *)
-
-open Lambda
-
-(* Input: a list of (key, action) pairs, where keys are integers. *)
-(* Output: a table of (low, high, offset) triples for Ktranslate
- an array of actions for Kswitch *)
-
-val make_decision_tree:
- (int * lambda) list -> (int * int * int) array * lambda array
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
deleted file mode 100644
index df97932a7d..0000000000
--- a/bytecomp/emitcode.ml
+++ /dev/null
@@ -1,285 +0,0 @@
-(* Generation of bytecode + relocation information *)
-
-open Config
-open Misc
-open Asttypes
-open Lambda
-open Instruct
-open Opcodes
-
-
-(* Relocation information *)
-
-type reloc_info =
- Reloc_literal of structured_constant (* structured constant *)
- | Reloc_getglobal of Ident.t (* reference to a global *)
- | Reloc_setglobal of Ident.t (* definition of a global *)
- | Reloc_primitive of string (* C primitive number *)
-
-(* Descriptor for compilation units *)
-
-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_interfaces: (string * int) list } (* Names and CRC of intfs imported *)
-
-(* Format of a .cmo file:
- Obj.magic number (Config.cmo_magic_number)
- absolute offset of compilation unit descriptor
- block of relocatable bytecode
- compilation unit descriptor *)
-
-(* Buffering of bytecode *)
-
-let out_buffer = ref(String.create 1024)
-and out_position = ref 0
-
-let out_word b1 b2 b3 b4 =
- let p = !out_position in
- if p >= String.length !out_buffer then begin
- let len = String.length !out_buffer in
- let new_buffer = String.create (2 * len) in
- String.blit !out_buffer 0 new_buffer 0 len;
- out_buffer := new_buffer
- end;
- String.unsafe_set !out_buffer p (Char.unsafe_chr b1);
- String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2);
- String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3);
- String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4);
- out_position := p + 4
-
-let out opcode =
- out_word opcode 0 0 0
-
-let out_int n =
- out_word n (n asr 8) (n asr 16) (n asr 24)
-
-(* Handling of local labels and backpatching *)
-
-type label_definition =
- Label_defined of int
- | Label_undefined of (int * int) list
-
-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.new !new_size (Label_undefined []) in
- Array.blit !label_table 0 new_table 0 (Array.length !label_table);
- label_table := new_table
-
-let backpatch (pos, orig) =
- let displ = (!out_position - orig) / 4 in
- !out_buffer.[pos] <- Char.unsafe_chr displ;
- !out_buffer.[pos+1] <- Char.unsafe_chr (displ lsr 8);
- !out_buffer.[pos+2] <- Char.unsafe_chr (displ lsr 16);
- !out_buffer.[pos+3] <- Char.unsafe_chr (displ lsr 24)
-
-let define_label lbl =
- if lbl >= Array.length !label_table then extend_label_table lbl;
- match (!label_table).(lbl) with
- Label_defined _ ->
- fatal_error "Emitcode.define_label"
- | Label_undefined patchlist ->
- List.iter backpatch patchlist;
- (!label_table).(lbl) <- Label_defined !out_position
-
-let out_label_with_orig orig lbl =
- if lbl >= Array.length !label_table then extend_label_table lbl;
- match (!label_table).(lbl) with
- Label_defined def ->
- out_int((def - orig) / 4)
- | Label_undefined patchlist ->
- (!label_table).(lbl) <-
- Label_undefined((!out_position, orig) :: patchlist);
- out_int 0
-
-let out_label l = out_label_with_orig !out_position l
-
-(* Relocation information *)
-
-let reloc_info = ref ([] : (reloc_info * int) list)
-
-let enter info =
- reloc_info := (info, !out_position) :: !reloc_info
-
-let slot_for_literal sc =
- enter (Reloc_literal sc);
- out_int 0
-and slot_for_getglobal id =
- enter (Reloc_getglobal id);
- out_int 0
-and slot_for_setglobal id =
- enter (Reloc_setglobal id);
- out_int 0
-and slot_for_c_prim name =
- enter (Reloc_primitive name);
- out_int 0
-
-(* Initialization *)
-
-let init () =
- out_position := 0;
- label_table := Array.new 16 (Label_undefined []);
- reloc_info := []
-
-(* Emission of one instruction *)
-
-let emit_instr = function
- Klabel lbl -> define_label lbl
- | Kacc n ->
- if n < 8 then out(opACC0 + n) else (out opACC; out_int n)
- | Kenvacc n ->
- if n < 4 then out(opENVACC0 + n) else (out opENVACC; out_int n)
- | Kpush ->
- out opPUSH
- | Kpop n ->
- out opPOP; out_int n
- | Kassign n ->
- out opASSIGN; out_int n
- | Kpush_retaddr lbl -> out opPUSH_RETADDR; out_label lbl
- | Kapply n ->
- if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n)
- | Kappterm(n, sz) ->
- if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz)
- else (out opAPPTERM; out_int n; out_int sz)
- | Kreturn n -> out opRETURN; out_int n
- | Krestart -> out opRESTART
- | Kgrab n -> out opGRAB; out_int n
- | Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl
- | Kclosurerec(lbl, n) -> out opCLOSUREREC; out_int n; out_label lbl
- | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q
- | Ksetglobal q -> out opSETGLOBAL; slot_for_setglobal q
- | Kconst sc ->
- begin match sc with
- Const_base(Const_int i) when i >= immed_min & i <= immed_max ->
- out opCONSTINT; out_int i
- | Const_base(Const_char c) ->
- out opCONSTINT; out_int (Char.code c)
- | Const_block(t, []) ->
- if t < 4 then out (opATOM0 + t) else (out opATOM; out_int t)
- | _ ->
- out opGETGLOBAL; slot_for_literal sc
- end
- | Kmakeblock(n, t) ->
- if n = 0 then
- if t < 4 then out (opATOM0 + t) else (out opATOM; out_int t)
- else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t)
- else (out opMAKEBLOCK; out_int n; out_int t)
- | Kgetfield n ->
- if n < 4 then out(opGETFIELD0 + n) else (out opGETFIELD; out_int n)
- | Ksetfield n ->
- if n < 4 then out(opSETFIELD0 + n) else (out opSETFIELD; out_int n)
- | Ktagof -> out opTAGOF
- | Kdummy n -> out opDUMMY; out_int n
- | Kupdate -> out opUPDATE
- | Kvectlength -> out opVECTLENGTH
- | Kgetvectitem -> out opGETVECTITEM
- | Ksetvectitem -> out opSETVECTITEM
- | Kgetstringchar -> out opGETSTRINGCHAR
- | Ksetstringchar -> out opSETSTRINGCHAR
- | Kbranch lbl -> out opBRANCH; out_label lbl
- | Kbranchif lbl -> out opBRANCHIF; out_label lbl
- | Kbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
- | Kstrictbranchif lbl -> out opBRANCHIF; out_label lbl
- | Kstrictbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
- | Kswitch lblv ->
- out opSWITCH; out_int (Array.length lblv);
- let org = !out_position in
- Array.iter (out_label_with_orig org) lblv
- | Ktranslate tbl ->
- out opTRANSLATE; out_int (Array.length tbl);
- Array.iter
- (fun (lo, hi, ofs) -> out_int (lo + (hi lsl 8) + (ofs lsl 16)))
- tbl
- | Kboolnot -> out opBOOLNOT
- | Kpushtrap lbl -> out opPUSHTRAP; out_label lbl
- | Kpoptrap -> out opPOPTRAP
- | Kraise -> out opRAISE
- | Kcheck_signals -> out opCHECK_SIGNALS
- | Kccall(name, n) ->
- if n <= 4
- then (out (opC_CALL1 + n - 1); slot_for_c_prim name)
- else (out opC_CALLN; out_int n; slot_for_c_prim name)
- | Knegint -> out opNEGINT | Kaddint -> out opADDINT
- | Ksubint -> out opSUBINT | Kmulint -> out opMULINT
- | Kdivint -> out opDIVINT | Kmodint -> out opMODINT
- | Kandint -> out opANDINT | Korint -> out opORINT
- | Kxorint -> out opXORINT | Klslint -> out opLSLINT
- | Klsrint -> out opLSRINT | Kasrint -> out opASRINT
- | Kintcomp Ceq -> out opEQ | Kintcomp Cneq -> out opNEQ
- | Kintcomp Clt -> out opLTINT | Kintcomp Cle -> out opLEINT
- | Kintcomp Cgt -> out opGTINT | Kintcomp Cge -> out opGEINT
- | Koffsetint n -> out opOFFSETINT; out_int n
- | Koffsetref n -> out opOFFSETREF; out_int n
- | Kstop -> out opSTOP
-
-(* Emission of a list of instructions. Include some peephole optimization. *)
-
-let rec emit = function
- [] -> ()
- (* Peephole optimizations *)
- | Kpush :: Kacc n :: c ->
- if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
- emit c
- | Kpush :: Kenvacc n :: c ->
- if n < 4 then out(opPUSHENVACC0 + n) else (out opPUSHENVACC; out_int n);
- emit c
- | Kpush :: Kgetglobal id :: Kgetfield n :: c ->
- out opPUSHGETGLOBALFIELD; slot_for_getglobal id; out n; emit c
- | Kpush :: Kgetglobal q :: c ->
- out opPUSHGETGLOBAL; slot_for_getglobal q; emit c
- | Kpush :: Kconst sc :: c ->
- begin match sc with
- Const_base(Const_int i) when i >= immed_min & i <= immed_max ->
- out opPUSHCONSTINT; out_int i
- | Const_base(Const_char c) ->
- out opPUSHCONSTINT; out_int(Char.code c)
- | Const_block(t, []) ->
- if t < 4 then out (opPUSHATOM0 + t) else (out opPUSHATOM; out_int t)
- | _ ->
- out opPUSHGETGLOBAL; slot_for_literal sc
- end;
- emit c
- | Kgetglobal id :: Kgetfield n :: c ->
- out opGETGLOBALFIELD; slot_for_getglobal id; out n; emit c
- (* Default case *)
- | instr :: c ->
- emit_instr instr; emit c
-
-(* Emission to a file *)
-
-let to_file outchan unit_name crc_interface code =
- init();
- output_string outchan cmo_magic_number;
- let pos_depl = pos_out outchan in
- output_binary_int outchan 0;
- let pos_code = pos_out outchan in
- emit code;
- output outchan !out_buffer 0 !out_position;
- let compunit =
- { cu_pos = pos_code;
- cu_codesize = !out_position;
- cu_reloc = List.rev !reloc_info;
- cu_interfaces = (unit_name, crc_interface) :: Env.imported_units() } in
- init(); (* Free out_buffer and reloc_info *)
- let pos_compunit = pos_out outchan in
- output_value outchan compunit;
- seek_out outchan pos_depl;
- output_binary_int outchan pos_compunit
-
-(* Emission to a memory block *)
-
-let to_memory init_code fun_code =
- init();
- emit init_code;
- emit fun_code;
- let code = Meta.static_alloc !out_position in
- String.unsafe_blit !out_buffer 0 code 0 !out_position;
- let reloc = List.rev !reloc_info
- and code_size = !out_position in
- init();
- (code, code_size, reloc)
-
diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
deleted file mode 100644
index 288e779f53..0000000000
--- a/bytecomp/emitcode.mli
+++ /dev/null
@@ -1,43 +0,0 @@
-(* Generation of bytecode for .cmo files *)
-
-open Lambda
-open Instruct
-
-(* Relocation information *)
-
-type reloc_info =
- Reloc_literal of structured_constant (* structured constant *)
- | Reloc_getglobal of Ident.t (* reference to a global *)
- | Reloc_setglobal of Ident.t (* definition of a global *)
- | Reloc_primitive of string (* C primitive number *)
-
-(* Descriptor for compilation units *)
-
-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_interfaces: (string * int) list } (* Names and CRC of intfs imported *)
-
-(* Format of a .cmo file:
- Obj.magic number (Config.cmo_magic_number)
- absolute offset of compilation unit descriptor
- block of relocatable bytecode
- compilation unit descriptor *)
-
-val to_file: out_channel -> string -> int -> instruction list -> unit
- (* Arguments:
- channel on output file
- name of compilation unit implemented
- CRC of interface implemented
- list of instructions to emit *)
-val to_memory: instruction list -> instruction list ->
- string * int * (reloc_info * int) list
- (* Arguments:
- initialization code (terminated by STOP)
- function code
- Results:
- block of relocatable bytecode
- size of this block
- relocation information *)
-
diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
deleted file mode 100644
index f312cbf746..0000000000
--- a/bytecomp/instruct.ml
+++ /dev/null
@@ -1,59 +0,0 @@
-open Lambda
-
-type label = int (* Symbolic code labels *)
-
-type instruction =
- Klabel of label
- | Kacc of int
- | Kenvacc of int
- | Kpush
- | Kpop of int
- | Kassign of int
- | Kpush_retaddr of label
- | Kapply of int (* number of arguments *)
- | Kappterm of int * int (* number of arguments, slot size *)
- | Kreturn of int (* slot size *)
- | Krestart
- | Kgrab of int (* number of arguments *)
- | Kclosure of label * int
- | Kclosurerec of label * int
- | Kgetglobal of Ident.t
- | Ksetglobal of Ident.t
- | Kconst of structured_constant
- | Kmakeblock of int * int (* size, tag *)
- | Kgetfield of int
- | Ksetfield of int
- | Ktagof
- | Kdummy of int
- | Kupdate
- | Kvectlength
- | Kgetvectitem
- | Ksetvectitem
- | Kgetstringchar
- | Ksetstringchar
- | Kbranch of label
- | Kbranchif of label
- | Kbranchifnot of label
- | Kstrictbranchif of label
- | Kstrictbranchifnot of label
- | Kswitch of label array
- | Ktranslate of (int * int * int) array
- | Kboolnot
- | Kpushtrap of label
- | Kpoptrap
- | Kraise
- | Kcheck_signals
- | Kccall of string * int
- | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint
- | Kandint | Korint | Kxorint | Klslint | Klsrint | Kasrint
- | Kintcomp of comparison
- | Koffsetint of int
- | Koffsetref of int
- | Kstop
-
-let immed_min = -0x40000000
-and immed_max = 0x3FFFFFFF
-
-(* Actually the abstract machine accomodates -0x80000000 to 0x7FFFFFFF,
- but these numbers overflow the Caml type int if the compiler runs on
- a 32-bit processor. *)
diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
deleted file mode 100644
index b2412029e1..0000000000
--- a/bytecomp/instruct.mli
+++ /dev/null
@@ -1,57 +0,0 @@
-(* The type of the instructions of the abstract machine *)
-
-open Lambda
-
-type label = int (* Symbolic code labels *)
-
-type instruction =
- Klabel of label
- | Kacc of int
- | Kenvacc of int
- | Kpush
- | Kpop of int
- | Kassign of int
- | Kpush_retaddr of label
- | Kapply of int (* number of arguments *)
- | Kappterm of int * int (* number of arguments, slot size *)
- | Kreturn of int (* slot size *)
- | Krestart
- | Kgrab of int (* number of arguments *)
- | Kclosure of label * int
- | Kclosurerec of label * int
- | Kgetglobal of Ident.t
- | Ksetglobal of Ident.t
- | Kconst of structured_constant
- | Kmakeblock of int * int (* size, tag *)
- | Kgetfield of int
- | Ksetfield of int
- | Ktagof
- | Kdummy of int
- | Kupdate
- | Kvectlength
- | Kgetvectitem
- | Ksetvectitem
- | Kgetstringchar
- | Ksetstringchar
- | Kbranch of label
- | Kbranchif of label
- | Kbranchifnot of label
- | Kstrictbranchif of label
- | Kstrictbranchifnot of label
- | Kswitch of label array
- | Ktranslate of (int * int * int) array
- | Kboolnot
- | Kpushtrap of label
- | Kpoptrap
- | Kraise
- | Kcheck_signals
- | Kccall of string * int
- | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint
- | Kandint | Korint | Kxorint | Klslint | Klsrint | Kasrint
- | Kintcomp of comparison
- | Koffsetint of int
- | Koffsetref of int
- | Kstop
-
-val immed_min: int
-val immed_max: int
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
deleted file mode 100644
index 8a13bdd3f6..0000000000
--- a/bytecomp/lambda.ml
+++ /dev/null
@@ -1,134 +0,0 @@
-open Path
-
-open Asttypes
-
-type primitive =
- Pidentity
- | Pgetglobal of Ident.t
- | Psetglobal of Ident.t
- | Pmakeblock of int
- | Ptagof
- | Pfield of int
- | Psetfield of int
- | Pccall of string * int
- | Pupdate
- | Praise
- | Psequand | Psequor | Pnot
- | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
- | Pandint | Porint | Pxorint
- | Plslint | Plsrint | Pasrint
- | Pcomp of comparison
- | Poffsetint of int
- | Poffsetref of int
- | Pgetstringchar | Psetstringchar
- | Pvectlength | Pgetvectitem | Psetvectitem
-
-and comparison =
- Ceq | Cneq | Clt | Cgt | Cle | Cge
-
-type structured_constant =
- Const_base of constant
- | Const_block of int * structured_constant list
-
-type lambda =
- Lvar of Ident.t
- | Lconst of structured_constant
- | Lapply of lambda * lambda list
- | Lfunction of Ident.t * lambda
- | Llet of Ident.t * lambda * lambda
- | Lletrec of (Ident.t * lambda * int) list * lambda
- | Lprim of primitive * lambda list
- | Lswitch of lambda * int * int * (int * lambda) list
- | Lstaticfail
- | Lcatch of lambda * lambda
- | Ltrywith of lambda * Ident.t * lambda
- | Lifthenelse of lambda * lambda * lambda
- | Lsequence of lambda * lambda
- | Lwhile of lambda * lambda
- | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
- | Lshared of lambda * int option ref
-
-let const_unit = Const_block(0, [])
-
-let lambda_unit = Lconst const_unit
-
-let share_lambda = function
- Lshared(_, _) as l -> l
- | l -> Lshared(l, ref None)
-
-let name_lambda arg fn =
- match arg with
- Lvar id -> fn id
- | _ -> let id = Ident.new "let" in Llet(id, arg, fn id)
-
-module IdentSet =
- Set.Make(struct
- type t = Ident.t
- let compare = compare
- end)
-
-let free_variables l =
- let fv = ref IdentSet.empty in
- let rec freevars = function
- Lvar id ->
- fv := IdentSet.add id !fv
- | Lconst sc -> ()
- | Lapply(fn, args) ->
- freevars fn; List.iter freevars args
- | Lfunction(param, body) ->
- freevars body; fv := IdentSet.remove param !fv
- | Llet(id, arg, body) ->
- freevars arg; freevars body; fv := IdentSet.remove id !fv
- | Lletrec(decl, body) ->
- freevars body;
- List.iter (fun (id, exp, sz) -> freevars exp) decl;
- List.iter (fun (id, exp, sz) -> fv := IdentSet.remove id !fv) decl
- | Lprim(p, args) ->
- List.iter freevars args
- | Lswitch(arg, lo, hi, cases) ->
- freevars arg; List.iter (fun (key, case) -> freevars case) cases
- | Lstaticfail -> ()
- | Lcatch(e1, e2) ->
- freevars e1; freevars e2
- | Ltrywith(e1, exn, e2) ->
- freevars e1; freevars e2; fv := IdentSet.remove exn !fv
- | Lifthenelse(e1, e2, e3) ->
- freevars e1; freevars e2; freevars e3
- | Lsequence(e1, e2) ->
- freevars e1; freevars e2
- | Lwhile(e1, e2) ->
- freevars e1; freevars e2
- | Lfor(v, e1, e2, dir, e3) ->
- freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv
- | Lshared(e, lblref) ->
- freevars e
- in freevars l; IdentSet.elements !fv
-
-(* Check if an action has a "when" guard *)
-
-let rec is_guarded = function
- Lifthenelse(cond, body, Lstaticfail) -> true
- | Lshared(lam, lbl) -> is_guarded lam
- | Llet(id, lam, body) -> is_guarded body
- | _ -> false
-
-type compilenv = lambda Ident.tbl
-
-let empty_env = Ident.empty
-
-let add_env = Ident.add
-
-let find_env = Ident.find_same
-
-let transl_access env id =
- try
- find_env id env
- with Not_found ->
- if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
-
-let rec transl_path = function
- Pident id ->
- if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
- | Pdot(p, s, pos) ->
- Lprim(Pfield pos, [transl_path p])
-
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
deleted file mode 100644
index ca2a0818f3..0000000000
--- a/bytecomp/lambda.mli
+++ /dev/null
@@ -1,64 +0,0 @@
-(* The "lambda" intermediate code *)
-
-open Asttypes
-
-type primitive =
- Pidentity
- | Pgetglobal of Ident.t
- | Psetglobal of Ident.t
- | Pmakeblock of int
- | Ptagof
- | Pfield of int
- | Psetfield of int
- | Pccall of string * int
- | Pupdate
- | Praise
- | Psequand | Psequor | Pnot
- | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
- | Pandint | Porint | Pxorint
- | Plslint | Plsrint | Pasrint
- | Pcomp of comparison
- | Poffsetint of int
- | Poffsetref of int
- | Pgetstringchar | Psetstringchar
- | Pvectlength | Pgetvectitem | Psetvectitem
-
-and comparison =
- Ceq | Cneq | Clt | Cgt | Cle | Cge
-
-type structured_constant =
- Const_base of constant
- | Const_block of int * structured_constant list
-
-type lambda =
- Lvar of Ident.t
- | Lconst of structured_constant
- | Lapply of lambda * lambda list
- | Lfunction of Ident.t * lambda
- | Llet of Ident.t * lambda * lambda
- | Lletrec of (Ident.t * lambda * int) list * lambda
- | Lprim of primitive * lambda list
- | Lswitch of lambda * int * int * (int * lambda) list
- | Lstaticfail
- | Lcatch of lambda * lambda
- | Ltrywith of lambda * Ident.t * lambda
- | Lifthenelse of lambda * lambda * lambda
- | Lsequence of lambda * lambda
- | Lwhile of lambda * lambda
- | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
- | Lshared of lambda * int option ref
-
-val const_unit: structured_constant
-val lambda_unit: lambda
-val share_lambda: lambda -> lambda
-val name_lambda: lambda -> (Ident.t -> lambda) -> lambda
-val free_variables: lambda -> Ident.t list
-val is_guarded: lambda -> bool
-
-type compilenv
-
-val empty_env: compilenv
-val add_env: Ident.t -> lambda -> compilenv -> compilenv
-val transl_access: compilenv -> Ident.t -> lambda
-
-val transl_path: Path.t -> lambda
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
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
deleted file mode 100644
index d2367cf139..0000000000
--- a/bytecomp/matching.ml
+++ /dev/null
@@ -1,262 +0,0 @@
-(* Compilation of pattern matching *)
-
-open Location
-open Asttypes
-open Typedtree
-open Lambda
-
-
-(* See Peyton-Jones, "The Implementation of functional programming
- languages", chapter 5. *)
-
-type pattern_matching =
- { mutable cases : (pattern list * lambda) list;
- args : lambda list }
-
-(* To group lines of patterns with identical keys *)
-
-let add_line patl_action pm =
- pm.cases <- patl_action :: pm.cases; pm
-
-let add make_matching_fun division key patl_action args =
- try
- let pm = List.assoc key division in
- pm.cases <- patl_action :: pm.cases;
- division
- with Not_found ->
- let pm = make_matching_fun args in
- pm.cases <- patl_action :: pm.cases;
- (key, pm) :: division
-
-(* To expand "or" patterns and remove aliases *)
-
-let rec simplify = function
- ({pat_desc = Tpat_alias(p, id)} :: patl, action) :: rem ->
- simplify((p :: patl, action) :: rem)
- | ({pat_desc = Tpat_or(p1, p2)} :: patl, action) :: rem ->
- let shared_action = share_lambda action in
- simplify((p1 :: patl, shared_action) ::
- (p2 :: patl, shared_action) :: rem)
- | cases ->
- cases
-
-(* Matching against a constant *)
-
-let make_constant_matching (arg :: argl) =
- {cases = []; args = argl}
-
-let divide_constant {cases = cl; args = al} =
- let rec divide cl =
- match simplify cl with
- ({pat_desc = Tpat_constant cst} :: patl, action) :: rem ->
- let (constants, others) = divide rem in
- (add make_constant_matching constants cst (patl, action) al, others)
- | cl ->
- ([], {cases = cl; args = al})
- in divide cl
-
-(* Matching against a constructor *)
-
-let make_constr_matching cstr (arg :: argl) =
- let (first_pos, last_pos) =
- match cstr.cstr_tag with
- Cstr_tag _ -> (0, cstr.cstr_arity - 1)
- | Cstr_exception _ -> (1, cstr.cstr_arity) in
- let rec make_args pos =
- if pos > last_pos
- then argl
- else Lprim(Pfield pos, [arg]) :: make_args (pos + 1) in
- {cases = []; args = make_args first_pos}
-
-let divide_constructor {cases = cl; args = al} =
- let rec divide cl =
- match simplify cl with
- ({pat_desc = Tpat_construct(cstr, args)} :: patl, action) :: rem ->
- let (constructs, others) = divide rem in
- (add (make_constr_matching cstr) constructs
- cstr.cstr_tag (args @ patl, action) al,
- others)
- | cl ->
- ([], {cases = cl; args = al})
- in divide cl
-
-(* Matching against a variable *)
-
-let divide_var {cases = cl; args = al} =
- let rec divide cl =
- match simplify cl with
- ({pat_desc = (Tpat_any | Tpat_var _)} :: patl, action) :: rem ->
- let (vars, others) = divide rem in
- (add_line (patl, action) vars, others)
- | cl ->
- (make_constant_matching al, {cases = cl; args = al})
- in divide cl
-
-(* Matching against a tuple pattern *)
-
-let make_tuple_matching num_comps (arg :: argl) =
- let rec make_args pos =
- if pos >= num_comps
- then argl
- else Lprim(Pfield pos, [arg]) :: make_args (pos + 1) in
- {cases = []; args = make_args 0}
-
-let any_pat =
- {pat_desc = Tpat_any; pat_loc = Location.none; pat_type = Ctype.none}
-
-let divide_tuple arity {cases = cl; args = al} =
- let rec divide cl =
- match simplify cl with
- ({pat_desc = Tpat_tuple args} :: patl, action) :: rem ->
- add_line (args @ patl, action) (divide rem)
- | ({pat_desc = (Tpat_any | Tpat_var _)} :: patl, action) :: rem ->
- let rec make_args n =
- if n >= arity then patl else any_pat :: make_args (n+1) in
- add_line (make_args 0, action) (divide rem)
- | [] ->
- make_tuple_matching arity al
- in divide cl
-
-(* Matching against a record pattern *)
-
-let divide_record num_fields {cases = cl; args = al} =
- let record_matching_line lbl_pat_list =
- let patv = Array.new num_fields any_pat in
- List.iter (fun (lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
- Array.to_list patv in
- let rec divide cl =
- match simplify cl with
- ({pat_desc = Tpat_record lbl_pat_list} :: patl, action) :: rem ->
- add_line (record_matching_line lbl_pat_list @ patl, action)
- (divide rem)
- | ({pat_desc = (Tpat_any | Tpat_var _)} :: patl, action) :: rem ->
- add_line (record_matching_line [] @ patl, action) (divide rem)
- | [] ->
- make_tuple_matching num_fields al
- in divide cl
-
-(* To List.combine sub-matchings together *)
-
-let combine_var (lambda1, total1) (lambda2, total2) =
- if total1 then (lambda1, true) else (Lcatch(lambda1, lambda2), total2)
-
-let combine_constant arg cst (const_lambda_list, total1) (lambda2, total2) =
- let lambda1 =
- match cst with
- Const_int _ ->
- List.fold_right
- (fun (c, act) rem ->
- Lifthenelse(
- Lprim(Pcomp Ceq, [arg; Lconst(Const_base c)]), act, rem))
- const_lambda_list Lstaticfail
- | Const_char _ ->
- Lswitch(arg, 0, 256,
- List.map (fun (Const_char c, l) -> (Char.code c, l))
- const_lambda_list)
- | Const_string _ | Const_float _ ->
- List.fold_right
- (fun (c, act) rem ->
- Lifthenelse(
- Lprim(Pccall("equal", 2), [arg; Lconst(Const_base c)]),
- act, rem))
- const_lambda_list Lstaticfail
- in (Lcatch(lambda1, lambda2), total2)
-
-let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
- if cstr.cstr_span < 0 then begin
- (* Special cases for exceptions *)
- let lambda1 =
- List.fold_right
- (fun (Cstr_exception path, act) rem ->
- Lifthenelse(Lprim(Pcomp Ceq, [Lprim(Pfield 0, [arg]);
- transl_path path]), act, rem))
- tag_lambda_list Lstaticfail
- in (Lcatch(lambda1, lambda2), total2)
- end else begin
- (* Regular concrete type *)
- let caselist =
- List.map (function (Cstr_tag n, act) -> (n, act)) tag_lambda_list in
- let lambda1 =
- match (caselist, cstr.cstr_span) with
- ([0, act], 1) -> act
- | ([0, act], 2) -> Lifthenelse(arg, Lstaticfail, act)
- | ([1, act], 2) -> Lifthenelse(arg, act, Lstaticfail)
- | ([0, act0; 1, act1], 2) -> Lifthenelse(arg, act1, act0)
- | ([1, act1; 0, act0], 2) -> Lifthenelse(arg, act1, act0)
- | _ ->
- if cstr.cstr_span < Config.max_tag
- then Lswitch(Lprim(Ptagof, [arg]), 0, cstr.cstr_span, caselist)
- else Lswitch(Lprim(Pfield 0, [arg]), 0, cstr.cstr_span, caselist) in
- if total1 & List.length tag_lambda_list = cstr.cstr_span
- then (lambda1, true)
- else (Lcatch(lambda1, lambda2), total2)
- end
-
-(* The main compilation function.
- Input: a pattern matching.
- Output: a lambda term, a "total" flag (true if we're sure that the
- matching covers all cases; this is an approximation). *)
-
-let rec compile_match m =
-
- let rec compile_list = function
- [] -> ([], true)
- | (key, pm) :: rem ->
- let (lambda1, total1) = compile_match pm in
- let (list2, total2) = compile_list rem in
- ((key, lambda1) :: list2, total1 & total2) in
-
- match { cases = simplify m.cases; args = m.args } with
- { cases = [] } ->
- (Lstaticfail, false)
- | { cases = ([], action) :: rem; args = argl } ->
- if is_guarded action then begin
- let (lambda, total) = compile_match { cases = rem; args = argl } in
- (Lcatch(action, lambda), total)
- end else
- (action, true)
- | { cases = (pat :: patl, action) :: _; args = arg :: _ } as pm ->
- match pat.pat_desc with
- Tpat_any | Tpat_var _ ->
- let (vars, others) = divide_var pm in
- combine_var (compile_match vars) (compile_match others)
- | Tpat_constant cst ->
- let (constants, others) = divide_constant pm in
- combine_constant arg cst
- (compile_list constants) (compile_match others)
- | Tpat_tuple patl ->
- compile_match (divide_tuple (List.length patl) pm)
- | Tpat_construct(cstr, patl) ->
- let (constrs, others) = divide_constructor pm in
- combine_constructor arg cstr
- (compile_list constrs) (compile_match others)
- | Tpat_record((lbl, _) :: _) ->
- compile_match (divide_record (Array.length lbl.lbl_all) pm)
-
-(* The entry points *)
-
-let compile_matching handler_fun arg pat_act_list =
- let pm =
- { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
- args = [arg] } in
- let (lambda, total) = compile_match pm in
- if total then lambda else Lcatch(lambda, handler_fun())
-
-let partial_function loc () =
- Lprim(Praise, [Lprim(Pmakeblock 0,
- [transl_path Predef.path_match_failure;
- Lconst(Const_block(0,
- [Const_base(Const_string !Location.input_name);
- Const_base(Const_int loc.loc_start);
- Const_base(Const_int loc.loc_end)]))])])
-
-let for_function loc param pat_act_list =
- compile_matching (partial_function loc) (Lvar param) pat_act_list
-
-let for_trywith param pat_act_list =
- compile_matching (fun () -> Lprim(Praise, [Lvar param]))
- (Lvar param) pat_act_list
-
-let for_let loc param pat body =
- compile_matching (partial_function loc) (Lvar param) [pat, body]
-
diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
deleted file mode 100644
index 21b6208019..0000000000
--- a/bytecomp/matching.mli
+++ /dev/null
@@ -1,11 +0,0 @@
-(* Compilation of pattern-matching *)
-
-open Typedtree
-open Lambda
-
-val for_function:
- Location.t -> Ident.t -> (pattern * lambda) list -> lambda
-val for_trywith:
- Ident.t -> (pattern * lambda) list -> lambda
-val for_let:
- Location.t -> Ident.t -> pattern -> lambda -> lambda
diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
deleted file mode 100644
index beb840dfcc..0000000000
--- a/bytecomp/printinstr.ml
+++ /dev/null
@@ -1,103 +0,0 @@
-(* Pretty-print lists of instructions *)
-
-open Format
-open Lambda
-open Instruct
-
-
-let instruction = function
- Klabel lbl -> print_string "L"; print_int lbl; print_string ":"
- | Kacc n -> print_string "\tacc "; print_int n
- | Kenvacc n -> print_string "\tenvacc "; print_int n
- | Kpush -> print_string "\tpush"
- | Kpop n -> print_string "\tpop "; print_int n
- | Kassign n -> print_string "\tassign "; print_int n
- | Kpush_retaddr lbl -> print_string "\tpush_retaddr L"; print_int lbl
- | Kapply n -> print_string "\tapply "; print_int n
- | Kappterm(n, m) ->
- print_string "\tappterm "; print_int n; print_string ", "; print_int m
- | Kreturn n -> print_string "\treturn "; print_int n
- | Krestart -> print_string "\trestart"
- | Kgrab n -> print_string "\tgrab "; print_int n
- | Kclosure(lbl, n) ->
- print_string "\tclosure L"; print_int lbl; print_string ", "; print_int n
- | Kclosurerec(lbl, n) ->
- print_string "\tclosurerec L"; print_int lbl;
- print_string ", "; print_int n
- | Kgetglobal id -> print_string "\tgetglobal "; Ident.print id
- | Ksetglobal id -> print_string "\tsetglobal "; Ident.print id
- | Kconst cst ->
- open_hovbox 10; print_string "\tconst"; print_space();
- Printlambda.structured_constant cst; close_box()
- | Kmakeblock(n, m) ->
- print_string "\tmakeblock "; print_int n; print_string ", "; print_int m
- | Kgetfield n -> print_string "\tgetfield "; print_int n
- | Ksetfield n -> print_string "\tsetfield "; print_int n
- | Ktagof -> print_string "\ttagof"
- | Kdummy n -> print_string "\tdummy "; print_int n
- | Kupdate -> print_string "\tupdate"
- | Kvectlength -> print_string "\tvectlength"
- | Kgetvectitem -> print_string "\tgetvectitem"
- | Ksetvectitem -> print_string "\tsetvectitem"
- | Kgetstringchar -> print_string "\tgetstringchar"
- | Ksetstringchar -> print_string "\tsetstringchar"
- | Kbranch lbl -> print_string "\tbranch L"; print_int lbl
- | Kbranchif lbl -> print_string "\tbranchif L"; print_int lbl
- | Kbranchifnot lbl -> print_string "\tbranchifnot L"; print_int lbl
- | Kstrictbranchif lbl -> print_string "\tstrictbranchif L"; print_int lbl
- | Kstrictbranchifnot lbl ->
- print_string "\tstrictbranchifnot L"; print_int lbl
- | Kswitch lblv ->
- open_hovbox 10;
- print_string "\tswitch";
- Array.iter (fun lbl -> print_space(); print_int lbl) lblv;
- close_box()
- | Ktranslate tbl ->
- open_hovbox 10;
- print_string "\ttranslate";
- Array.iter
- (fun (lo, hi, ofs) ->
- print_space(); print_int lo; print_string "/";
- print_int hi; print_string "/"; print_int ofs)
- tbl;
- close_box()
- | Kboolnot -> print_string "\tboolnot"
- | Kpushtrap lbl -> print_string "\tpushtrap L"; print_int lbl
- | Kpoptrap -> print_string "\tpoptrap"
- | Kraise -> print_string "\traise"
- | Kcheck_signals -> print_string "\tcheck_signals"
- | Kccall(s, n) ->
- print_string "\tccall "; print_string s; print_string ", "; print_int n
- | Knegint -> print_string "\tnegint"
- | Kaddint -> print_string "\taddint"
- | Ksubint -> print_string "\tsubint"
- | Kmulint -> print_string "\tmulint"
- | Kdivint -> print_string "\tdivint"
- | Kmodint -> print_string "\tmodint"
- | Kandint -> print_string "\tandint"
- | Korint -> print_string "\torint"
- | Kxorint -> print_string "\txorint"
- | Klslint -> print_string "\tlslint"
- | Klsrint -> print_string "\tlsrint"
- | Kasrint -> print_string "\tasrint"
- | Kintcomp Ceq -> print_string "\teqint"
- | Kintcomp Cneq -> print_string "\tneqint"
- | Kintcomp Clt -> print_string "\tltint"
- | Kintcomp Cgt -> print_string "\tgtint"
- | Kintcomp Cle -> print_string "\tleint"
- | Kintcomp Cge -> print_string "\tgeint"
- | Koffsetint n -> print_string "\toffsetint "; print_int n
- | Koffsetref n -> print_string "\toffsetref "; print_int n
- | Kstop -> print_string "\tstop"
-
-let rec instruction_list = function
- [] -> ()
- | Klabel lbl :: il ->
- print_string "L"; print_int lbl; print_string ":"; instruction_list il
- | instr :: il ->
- instruction instr; print_space(); instruction_list il
-
-let instrlist il =
- open_vbox 0;
- instruction_list il;
- close_box()
diff --git a/bytecomp/printinstr.mli b/bytecomp/printinstr.mli
deleted file mode 100644
index 6ccadfedde..0000000000
--- a/bytecomp/printinstr.mli
+++ /dev/null
@@ -1,6 +0,0 @@
-(* Pretty-print lists of instructions *)
-
-open Instruct
-
-val instruction: instruction -> unit
-val instrlist: instruction list -> unit
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
deleted file mode 100644
index 001209d78a..0000000000
--- a/bytecomp/printlambda.ml
+++ /dev/null
@@ -1,195 +0,0 @@
-open Format
-open Asttypes
-open Lambda
-
-
-let rec structured_constant = function
- Const_base(Const_int n) -> print_int n
- | Const_base(Const_char c) ->
- print_string "'"; print_string(Char.escaped c); print_string "'"
- | Const_base(Const_string s) ->
- print_string "\""; print_string(String.escaped s); print_string "\""
- | Const_base(Const_float s) ->
- print_string s
- | Const_block(tag, []) ->
- print_string "["; print_int tag; print_string "]"
- | Const_block(tag, sc1::scl) ->
- open_hovbox 1;
- print_string "["; print_int tag; print_string ":";
- print_space();
- open_hovbox 0;
- structured_constant sc1;
- List.iter (fun sc -> print_space(); structured_constant sc) scl;
- close_box();
- print_string "]";
- close_box()
-
-let primitive = function
- Pidentity -> print_string "id"
- | Pgetglobal id -> print_string "global "; Ident.print id
- | Psetglobal id -> print_string "setglobal "; Ident.print id
- | Pmakeblock sz -> print_string "makeblock "; print_int sz
- | Ptagof -> print_string "tag"
- | Pfield n -> print_string "field "; print_int n
- | Psetfield n -> print_string "setfield "; print_int n
- | Pccall(name, arity) -> print_string name
- | Pupdate -> print_string "update"
- | Praise -> print_string "raise"
- | Psequand -> print_string "&&"
- | Psequor -> print_string "||"
- | Pnot -> print_string "not"
- | Pnegint -> print_string "~"
- | Paddint -> print_string "+"
- | Psubint -> print_string "-"
- | Pmulint -> print_string "*"
- | Pdivint -> print_string "/"
- | Pmodint -> print_string "mod"
- | Pandint -> print_string "and"
- | Porint -> print_string "or"
- | Pxorint -> print_string "xor"
- | Plslint -> print_string "lsl"
- | Plsrint -> print_string "lsr"
- | Pasrint -> print_string "asr"
- | Pcomp(Ceq) -> print_string "=="
- | Pcomp(Cneq) -> print_string "!="
- | Pcomp(Clt) -> print_string "<"
- | Pcomp(Cle) -> print_string "<="
- | Pcomp(Cgt) -> print_string ">"
- | Pcomp(Cge) -> print_string ">="
- | Poffsetint n -> print_int n; print_string "+"
- | Poffsetref n -> print_int n; print_string "+:="
- | Pgetstringchar -> print_string "string.get"
- | Psetstringchar -> print_string "string.set"
- | Pvectlength -> print_string "array.length"
- | Pgetvectitem -> print_string "array.get"
- | Psetvectitem -> print_string "array.set"
-
-let rec lambda = function
- Lvar id ->
- Ident.print id
- | Lconst cst ->
- structured_constant cst
- | Lapply(lfun, largs) ->
- open_hovbox 2;
- print_string "(apply"; print_space();
- lambda lfun;
- List.iter (fun l -> print_space(); lambda l) largs;
- print_string ")";
- close_box()
- | Lfunction(param, body) ->
- open_hovbox 2;
- print_string "(function"; print_space(); Ident.print param;
- print_space(); lambda body; print_string ")"; close_box()
- | Llet(id, arg, body) ->
- open_hovbox 2;
- print_string "(let"; print_space();
- open_hvbox 1;
- print_string "(";
- open_hovbox 2; Ident.print id; print_space(); lambda arg; close_box();
- letbody body;
- print_string ")";
- close_box()
- | Lletrec(id_arg_list, body) ->
- open_hovbox 2;
- print_string "(letrec"; print_space();
- open_hvbox 1;
- print_string "(";
- let spc = ref false in
- List.iter
- (fun (id, l, sz) ->
- if !spc then print_space() else spc := true;
- Ident.print id; print_string " "; lambda l)
- id_arg_list;
- close_box();
- print_string ")";
- print_space(); lambda body;
- print_string ")"; close_box()
- | Lprim(prim, largs) ->
- open_hovbox 2;
- print_string "("; primitive prim;
- List.iter (fun l -> print_space(); lambda l) largs;
- print_string ")";
- close_box()
- | Lswitch(larg, lo, hi, cases) ->
- open_hovbox 1;
- print_string "(switch "; print_int lo; print_string "/";
- print_int hi; print_space();
- lambda larg; print_space();
- open_vbox 0;
- let spc = ref false in
- List.iter
- (fun (n, l) ->
- open_hvbox 1;
- print_string "case "; print_int n; print_string ":"; print_space();
- lambda l;
- close_box();
- if !spc then print_space() else spc := true)
- cases;
- print_string ")"; close_box(); close_box()
- | Lstaticfail ->
- print_string "exit"
- | Lcatch(lbody, lhandler) ->
- open_hovbox 2;
- print_string "(catch"; print_space();
- lambda lbody; print_break(1, -1);
- print_string "with"; print_space(); lambda lhandler;
- print_string ")";
- close_box()
- | Ltrywith(lbody, param, lhandler) ->
- open_hovbox 2;
- print_string "(try"; print_space();
- lambda lbody; print_break(1, -1);
- print_string "with "; Ident.print param; print_space();
- lambda lhandler;
- print_string ")";
- close_box()
- | Lifthenelse(lcond, lif, lelse) ->
- open_hovbox 2;
- print_string "(if"; print_space();
- lambda lcond; print_space();
- lambda lif; print_space();
- lambda lelse; print_string ")";
- close_box()
- | Lsequence(l1, l2) ->
- open_hovbox 2;
- print_string "(seq"; print_space();
- lambda l1; print_space(); sequence l2; print_string ")";
- close_box()
- | Lwhile(lcond, lbody) ->
- open_hovbox 2;
- print_string "(while"; print_space();
- lambda lcond; print_space();
- lambda lbody; print_string ")";
- close_box()
- | Lfor(param, lo, hi, dir, body) ->
- open_hovbox 2;
- print_string "(for "; Ident.print param; print_space();
- lambda lo; print_space();
- print_string(match dir with Upto -> "to" | Downto -> "downto");
- print_space();
- lambda hi; print_space();
- lambda body; print_string ")";
- close_box()
- | Lshared(l, lbl) ->
- lambda l
-
-and sequence = function
- Lsequence(l1, l2) ->
- sequence l1; print_space(); sequence l2
- | l ->
- lambda l
-
-and letbody = function
- Llet(id, arg, body) ->
- print_space();
- open_hovbox 2; Ident.print id; print_space(); lambda arg;
- close_box();
- letbody body
- | Lshared(l, lbl) ->
- letbody l
- | l ->
- print_string ")";
- close_box();
- print_space();
- lambda l
-
diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli
deleted file mode 100644
index 3dbebb7011..0000000000
--- a/bytecomp/printlambda.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-open Lambda
-
-val structured_constant: structured_constant -> unit
-val lambda: lambda -> unit
diff --git a/bytecomp/runtimedef.mli b/bytecomp/runtimedef.mli
deleted file mode 100644
index 48ba14599d..0000000000
--- a/bytecomp/runtimedef.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-(* Values and functions known and/or provided by the runtime system *)
-
-val builtin_exceptions: string array
-val builtin_primitives: string array
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
deleted file mode 100644
index d4d14c2974..0000000000
--- a/bytecomp/symtable.ml
+++ /dev/null
@@ -1,223 +0,0 @@
-(* To assign numbers to globals and primitives *)
-
-open Misc
-open Asttypes
-open Lambda
-open Emitcode
-
-
-(* Functions for batch linking *)
-
-type error =
- Undefined_global of string
- | Unavailable_primitive of string
-
-exception Error of error
-
-(* Tables for numbering objects *)
-
-type 'a numtable =
- { num_cnt: int; (* The next number *)
- num_tbl: ('a, int) Tbl.t } (* The table of already numbered objects *)
-
-let empty_numtable = { num_cnt = 0; num_tbl = Tbl.empty }
-
-let find_numtable nt key =
- Tbl.find key nt.num_tbl
-
-let enter_numtable nt key =
- let n = !nt.num_cnt in
- nt := { num_cnt = n + 1; num_tbl = Tbl.add key n !nt.num_tbl };
- n
-
-let incr_numtable nt =
- let n = !nt.num_cnt in
- nt := { num_cnt = n + 1; num_tbl = !nt.num_tbl };
- n
-
-(* Global variables *)
-
-let global_table = ref(empty_numtable : Ident.t numtable)
-and literal_table = ref([] : (int * structured_constant) list)
-
-let slot_for_getglobal id =
- try
- find_numtable !global_table id
- with Not_found ->
- raise(Error(Undefined_global(Ident.name id)))
-
-let slot_for_setglobal id =
- enter_numtable global_table id
-
-let slot_for_literal cst =
- let n = incr_numtable global_table in
- literal_table := (n, cst) :: !literal_table;
- n
-
-(* The C primitives *)
-
-let c_prim_table = ref(empty_numtable : string numtable)
-
-let num_of_prim name =
- try
- find_numtable !c_prim_table name
- with Not_found ->
- if !Clflags.custom_runtime
- then enter_numtable c_prim_table name
- else raise(Error(Unavailable_primitive name))
-
-open Printf
-
-let output_primitives prim_file_name =
- let oc = open_out prim_file_name in
- let prim = Array.new !c_prim_table.num_cnt "" in
- Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl;
- for i = 0 to Array.length prim - 1 do
- fprintf oc "extern long %s();\n" prim.(i)
- done;
- fprintf oc "typedef long (*primitive)();\n";
- fprintf oc "primitive cprim[] = {\n";
- for i = 0 to Array.length prim - 1 do
- fprintf oc " %s,\n" prim.(i)
- done;
- fprintf oc " (primitive) 0 };\n";
- fprintf oc "char * names_of_cprim[] = {\n";
- for i = 0 to Array.length prim - 1 do
- fprintf oc " \"%s\",\n" prim.(i)
- done;
- fprintf oc " (char *) 0 };\n";
- close_out oc
-
-(* Initialization for batch linking *)
-
-let init () =
- (* Enter the predefined exceptions *)
- Array.iter
- (fun name ->
- let id =
- try List.assoc name Predef.builtin_values
- with Not_found -> fatal_error "Symtable.init" in
- let c = slot_for_setglobal id in
- let cst = Const_block(0, [Const_base(Const_string name)]) in
- literal_table := (c, cst) :: !literal_table)
- Runtimedef.builtin_exceptions;
- (* Enter the known C primitives *)
- Array.iter (enter_numtable c_prim_table) Runtimedef.builtin_primitives
-
-(* Relocate a block of object bytecode *)
-
-(* Must use the unsafe String.set here because the block may be
- a "fake" string as returned by Meta.static_alloc. *)
-let patch_short buff pos n =
- String.unsafe_set buff pos (Char.unsafe_chr n);
- String.unsafe_set buff (succ pos) (Char.unsafe_chr (n asr 8))
-
-let patch_object buff patchlist =
- List.iter
- (function
- (Reloc_literal sc, pos) ->
- patch_short buff pos (slot_for_literal sc)
- | (Reloc_getglobal id, pos) ->
- patch_short buff pos (slot_for_getglobal id)
- | (Reloc_setglobal id, pos) ->
- patch_short buff pos (slot_for_setglobal id)
- | (Reloc_primitive name, pos) ->
- patch_short buff pos (num_of_prim name))
- patchlist
-
-(* Translate structured constants *)
-
-let rec transl_const = function
- Const_base(Const_int i) -> Obj.repr i
- | Const_base(Const_char c) -> Obj.repr c
- | Const_base(Const_string s) -> Obj.repr s
- | Const_base(Const_float f) -> Obj.repr(float_of_string f)
- | Const_block(tag, fields) ->
- let block = Obj.new_block tag (List.length fields) in
- let pos = ref 0 in
- List.iter
- (fun c -> Obj.set_field block !pos (transl_const c); incr pos)
- fields;
- block
-
-(* Build the initial table of globals *)
-
-let initial_global_table () =
- let glob = Array.new !global_table.num_cnt (Obj.repr 0) in
- List.iter
- (fun (slot, cst) -> glob.(slot) <- transl_const cst)
- !literal_table;
- literal_table := [];
- glob
-
-(* Save the table of globals *)
-
-let output_global_map oc =
- output_compact_value oc !global_table
-
-(* Functions for toplevel use *)
-
-(* Update the in-core table of globals *)
-
-let update_global_table () =
- let ng = !global_table.num_cnt in
- if ng >= Array.length(Meta.global_data()) then Meta.realloc_global_data ng;
- let glob = Meta.global_data() in
- List.iter
- (fun (slot, cst) -> glob.(slot) <- transl_const cst)
- !literal_table;
- literal_table := []
-
-(* Initialize the linker for toplevel use *)
-
-let init_toplevel () =
- (* Read back the known global symbols from the executable file *)
- let ic = open_in_bin Sys.argv.(0) in
- let pos_trailer =
- in_channel_length ic - 16 - String.length Config.exec_magic_number in
- seek_in ic pos_trailer;
- let code_size = input_binary_int ic in
- let data_size = input_binary_int ic in
- let symbol_size = input_binary_int ic in
- let debug_size = input_binary_int ic in
- seek_in ic (pos_trailer - debug_size - symbol_size);
- global_table := (input_value ic : Ident.t numtable);
- close_in ic;
- (* Enter the known C primitives *)
- Array.iter (enter_numtable c_prim_table) (Meta.available_primitives())
-
-(* Find the value of a global identifier *)
-
-let get_global_value id =
- (Meta.global_data()).(slot_for_getglobal id)
-and assign_global_value id v =
- (Meta.global_data()).(slot_for_getglobal id) <- v
-
-(* Save and restore the current state *)
-
-type global_map = Ident.t numtable
-
-let current_state () = !global_table
-and restore_state st = global_table := st
-
-(* "Filter" the global List.map according to some predicate.
- Used to expunge the global List.map for the toplevel. *)
-
-let filter_global_map p gmap =
- let newtbl = ref Tbl.empty in
- Tbl.iter
- (fun id num -> if p id then newtbl := Tbl.add id num !newtbl)
- gmap.num_tbl;
- {num_cnt = gmap.num_cnt; num_tbl = !newtbl}
-
-(* Error report *)
-
-open Format
-
-let report_error = function
- Undefined_global s ->
- print_string "Reference to undefined global `"; print_string s;
- print_string "'"
- | Unavailable_primitive s ->
- print_string "The external function `"; print_string s;
- print_string "' is not available"
diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli
deleted file mode 100644
index 0fec140198..0000000000
--- a/bytecomp/symtable.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-(* Assign locations and numbers to globals and primitives *)
-
-open Emitcode
-
-(* Functions for batch linking *)
-
-val init: unit -> unit
-val patch_object: string -> (reloc_info * int) list -> unit
-val initial_global_table: unit -> Obj.t array
-val output_global_map: out_channel -> unit
-val output_primitives: string -> unit
-
-(* Functions for the toplevel *)
-
-val init_toplevel: unit -> unit
-val update_global_table: unit -> unit
-val get_global_value: Ident.t -> Obj.t
-val assign_global_value: Ident.t -> Obj.t -> unit
-
-type global_map
-
-val current_state: unit -> global_map
-val restore_state: global_map -> unit
-val filter_global_map: (Ident.t -> bool) -> global_map -> global_map
-
-(* Error report *)
-
-type error =
- Undefined_global of string
- | Unavailable_primitive of string
-
-exception Error of error
-
-val report_error: error -> unit
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
deleted file mode 100644
index 8122dcad5d..0000000000
--- a/bytecomp/translcore.ml
+++ /dev/null
@@ -1,344 +0,0 @@
-(* Translation from typed abstract syntax to lambda terms,
- for the core language *)
-
-open Misc
-open Asttypes
-open Path
-open Typedtree
-open Lambda
-
-
-type error =
- Illegal_letrec_pat
- | Illegal_letrec_expr
-
-exception Error of Location.t * error
-
-(* The translation environment maps identifiers bound by patterns
- to lambda-terms, e.g. access paths.
- Identifiers unbound in the environment List.map to themselves. *)
-
-(* Compute the access paths to identifiers bound in patterns. *)
-
-let rec bind_pattern env pat arg mut =
- match pat.pat_desc with
- Tpat_var id ->
- begin match mut with
- Mutable -> (env, fun e -> Llet(id, arg, e))
- | Immutable -> (add_env id arg env, fun e -> e)
- end
- | Tpat_alias(pat, id) ->
- let (ext_env, bind) = bind_pattern env pat arg mut in
- begin match mut with
- Mutable -> (ext_env, fun e -> Llet(id, arg, bind e))
- | Immutable -> (add_env id arg ext_env, bind)
- end
- | Tpat_tuple patl ->
- bind_pattern_list env patl arg mut 0
- | Tpat_construct(cstr, patl) ->
- bind_pattern_list env patl arg mut
- (match cstr.cstr_tag with
- Cstr_tag _ -> 0
- | Cstr_exception _ -> 1)
- | Tpat_record lbl_pat_list ->
- bind_label_pattern env lbl_pat_list arg mut
- | _ ->
- (env, fun e -> e)
-
-and bind_pattern_list env patl arg mut pos =
- match patl with
- [] -> (env, fun e -> e)
- | pat :: rem ->
- let (env1, bind1) =
- bind_pattern env pat (Lprim(Pfield pos, [arg])) mut in
- let (env2, bind2) =
- bind_pattern_list env1 rem arg mut (pos+1) in
- (env2, fun e -> bind1(bind2 e))
-
-and bind_label_pattern env patl arg mut =
- match patl with
- [] -> (env, fun e -> e)
- | (lbl, pat) :: rem ->
- let mut1 =
- match lbl.lbl_mut with Mutable -> Mutable | Immutable -> mut in
- let (env1, bind1) =
- bind_pattern env pat (Lprim(Pfield lbl.lbl_pos, [arg])) mut1 in
- let (env2, bind2) =
- bind_label_pattern env1 rem arg mut in
- (env2, fun e -> bind1(bind2 e))
-
-(* Translation of primitives *)
-
-let comparisons_table = create_hashtable 11 [
- "%equal",
- (Pccall("equal", 2), Pcomp Ceq, Pccall("eq_float", 2));
- "%notequal",
- (Pccall("notequal", 2), Pcomp Cneq, Pccall("neq_float", 2));
- "%lessthan",
- (Pccall("lessthan", 2), Pcomp Clt, Pccall("lt_float", 2));
- "%greaterthan",
- (Pccall("greaterthan", 2), Pcomp Cgt, Pccall("gt_float", 2));
- "%lessequal",
- (Pccall("lessequal", 2), Pcomp Cle, Pccall("le_float", 2));
- "%greaterequal",
- (Pccall("greaterequal", 2), Pcomp Cge, Pccall("ge_float", 2))
-]
-
-let primitives_table = create_hashtable 31 [
- "%identity", Pidentity;
- "%tagof", Ptagof;
- "%field0", Pfield 0;
- "%field1", Pfield 1;
- "%setfield0", Psetfield 0;
- "%makeblock", Pmakeblock 0;
- "%update", Pupdate;
- "%raise", Praise;
- "%sequand", Psequand;
- "%sequor", Psequor;
- "%boolnot", Pnot;
- "%negint", Pnegint;
- "%succint", Poffsetint 1;
- "%predint", Poffsetint(-1);
- "%addint", Paddint;
- "%subint", Psubint;
- "%mulint", Pmulint;
- "%divint", Pdivint;
- "%modint", Pmodint;
- "%andint", Pandint;
- "%orint", Porint;
- "%xorint", Pxorint;
- "%lslint", Plslint;
- "%lsrint", Plsrint;
- "%asrint", Pasrint;
- "%eq", Pcomp Ceq;
- "%noteq", Pcomp Cneq;
- "%ltint", Pcomp Clt;
- "%leint", Pcomp Cle;
- "%gtint", Pcomp Cgt;
- "%geint", Pcomp Cge;
- "%incr", Poffsetref(1);
- "%decr", Poffsetref(-1);
- "%string_unsafe_get", Pgetstringchar;
- "%string_unsafe_set", Psetstringchar;
- "%array_length", Pvectlength;
- "%array_unsafe_get", Pgetvectitem;
- "%array_unsafe_set", Psetvectitem
-]
-
-let same_base_type ty1 ty2 =
- match (Ctype.repr ty1, Ctype.repr ty2) with
- (Tconstr(p1, []), Tconstr(p2, [])) -> Path.same p1 p2
- | (_, _) -> false
-
-let transl_prim prim arity args =
- try
- let (gencomp, intcomp, floatcomp) =
- Hashtbl.find comparisons_table prim in
- match args with
- [arg1; arg2] when same_base_type arg1.exp_type Predef.type_int
- or same_base_type arg1.exp_type Predef.type_char ->
- intcomp
- | [arg1; arg2] when same_base_type arg1.exp_type Predef.type_float ->
- floatcomp
- | _ ->
- gencomp
- with Not_found ->
- try
- Hashtbl.find primitives_table prim
- with Not_found ->
- Pccall(prim, arity)
-
-(* To compile "let rec" *)
-
-exception Unknown
-
-let size_of_lambda id lam =
- let rec size = function
- Lfunction(param, body) -> 2
- | Lprim(Pmakeblock tag, args) -> List.iter check args; List.length args
- | Llet(id, arg, body) -> check arg; size body
- | _ -> raise Unknown
- and check = function
- Lvar _ -> ()
- | Lconst cst -> ()
- | Lfunction(param, body) -> ()
- | Llet(_, arg, body) -> check arg; check body
- | Lprim(Pmakeblock tag, args) -> List.iter check args
- | lam -> if List.mem id (free_variables lam) then raise Unknown
- in size lam
-
-(* To propagate structured constants *)
-
-exception Not_constant
-
-let extract_constant = function Lconst sc -> sc | _ -> raise Not_constant
-
-(* Translation of expressions *)
-
-let rec transl_exp env e =
- match e.exp_desc with
- Texp_ident(path, desc) ->
- begin match path with
- Pident id -> transl_access env id
- | _ -> transl_path path
- end
- | Texp_constant cst ->
- Lconst(Const_base cst)
- | Texp_let(rec_flag, pat_expr_list, body) ->
- let (ext_env, add_let) = transl_let env rec_flag pat_expr_list in
- add_let(transl_exp ext_env body)
- | Texp_function pat_expr_list ->
- let param = Ident.new "fun" in
- Lfunction(param, Matching.for_function e.exp_loc param
- (transl_cases env param pat_expr_list))
- | Texp_apply({exp_desc = Texp_ident(path, {val_prim = Primitive(s, arity)})},
- args) when List.length args = arity ->
- Lprim(transl_prim s arity args, transl_list env args)
- | Texp_apply(funct, args) ->
- Lapply(transl_exp env funct, transl_list env args)
- | Texp_match(arg, pat_expr_list) ->
- name_lambda (transl_exp env arg)
- (fun id ->
- Matching.for_function e.exp_loc id
- (transl_cases env id pat_expr_list))
- | Texp_try(body, pat_expr_list) ->
- let id = Ident.new "exn" in
- Ltrywith(transl_exp env body, id,
- Matching.for_trywith id (transl_cases env id pat_expr_list))
- | Texp_tuple el ->
- let ll = transl_list env el in
- begin try
- Lconst(Const_block(0, List.map extract_constant ll))
- with Not_constant ->
- Lprim(Pmakeblock 0, ll)
- end
- | Texp_construct(cstr, args) ->
- let ll = transl_list env args in
- begin match cstr.cstr_tag with
- Cstr_tag n ->
- begin try
- Lconst(Const_block(n, List.map extract_constant ll))
- with Not_constant ->
- Lprim(Pmakeblock n, ll)
- end
- | Cstr_exception path ->
- Lprim(Pmakeblock 0, transl_path path :: ll)
- end
- | Texp_record lbl_expr_list ->
- let lv = Array.new (List.length lbl_expr_list) Lstaticfail in
- List.iter
- (fun (lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp env expr)
- lbl_expr_list;
- let ll = Array.to_list lv in
- if List.for_all (fun (lbl, expr) -> lbl.lbl_mut = Immutable) lbl_expr_list
- then begin
- try
- Lconst(Const_block(0, List.map extract_constant ll))
- with Not_constant ->
- Lprim(Pmakeblock 0, ll)
- end else
- Lprim(Pmakeblock 0, ll)
- | Texp_field(arg, lbl) ->
- Lprim(Pfield lbl.lbl_pos, [transl_exp env arg])
- | Texp_setfield(arg, lbl, newval) ->
- Lprim(Psetfield lbl.lbl_pos,
- [transl_exp env arg; transl_exp env newval])
- | Texp_array expr_list ->
- Lprim(Pmakeblock 0, transl_list env expr_list)
- | Texp_ifthenelse(cond, ifso, Some ifnot) ->
- Lifthenelse(transl_exp env cond, transl_exp env ifso,
- transl_exp env ifnot)
- | Texp_ifthenelse(cond, ifso, None) ->
- Lifthenelse(transl_exp env cond, transl_exp env ifso, lambda_unit)
- | Texp_sequence(expr1, expr2) ->
- Lsequence(transl_exp env expr1, transl_exp env expr2)
- | Texp_while(cond, body) ->
- Lwhile(transl_exp env cond, transl_exp env body)
- | Texp_for(param, low, high, dir, body) ->
- Lfor(param, transl_exp env low, transl_exp env high, dir,
- transl_exp env body)
- | Texp_when(cond, body) ->
- Lifthenelse(transl_exp env cond, transl_exp env body, Lstaticfail)
-
-and transl_list env = function
- [] -> []
- | expr :: rem -> transl_exp env expr :: transl_list env rem
-
-and transl_cases env param pat_expr_list =
- let transl_case (pat, expr) =
- let (ext_env, bind_fun) = bind_pattern env pat (Lvar param) Immutable in
- (pat, bind_fun(transl_exp ext_env expr)) in
- List.map transl_case pat_expr_list
-
-and transl_let env rec_flag pat_expr_list =
- match rec_flag with
- Nonrecursive ->
- let rec transl body_env = function
- [] ->
- (body_env, fun e -> e)
- | (pat, expr) :: rem ->
- let id = Ident.new "let" in
- let (ext_env, bind_fun) =
- bind_pattern body_env pat (Lvar id) Immutable in
- let (final_env, add_let_fun) =
- transl ext_env rem in
- (final_env,
- fun e -> Llet(id, transl_exp env expr,
- Matching.for_let pat.pat_loc id pat
- (bind_fun(add_let_fun e)))) in
- transl env pat_expr_list
- | Recursive ->
- let transl_case (pat, expr) =
- let id =
- match pat.pat_desc with
- Tpat_var id -> id
- | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)) in
- let lam = transl_exp env expr in
- let size =
- try size_of_lambda id lam
- with Unknown -> raise(Error(expr.exp_loc, Illegal_letrec_expr)) in
- (id, lam, size) in
- let decls =
- List.map transl_case pat_expr_list in
- (env, fun e -> Lletrec(decls, e))
-
-(* Compile a primitive definition *)
-
-let transl_primitive = function
- Not_prim -> fatal_error "Translcore.transl_primitive"
- | Primitive(name, arity) ->
- let prim =
- try
- let (gencomp, intcomp, floatcomp) =
- Hashtbl.find comparisons_table name in
- gencomp
- with Not_found ->
- try
- Hashtbl.find primitives_table name
- with Not_found ->
- Pccall(name, arity) in
- let rec add_params n params =
- if n >= arity
- then Lprim(prim, List.rev params)
- else begin
- let id = Ident.new "prim" in
- Lfunction(id, add_params (n+1) (Lvar id :: params))
- end in
- add_params 0 []
-
-(* Compile an exception definition *)
-
-let transl_exception id decl =
- Lprim(Pmakeblock 0, [Lconst(Const_base(Const_string(Ident.name id)))])
-
-(* Error report *)
-
-open Format
-
-let report_error = function
- Illegal_letrec_pat ->
- print_string
- "Only variables are allowed as left-hand side of `let rec'"
- | Illegal_letrec_expr ->
- print_string
- "This kind of expression is not allowed as right-hand side of `let rec'"
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
deleted file mode 100644
index 9fa9835a7b..0000000000
--- a/bytecomp/translcore.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(* Translation from typed abstract syntax to lambda terms,
- for the core language *)
-
-open Asttypes
-open Typedtree
-open Lambda
-
-val transl_exp: compilenv -> expression -> lambda
-val transl_let:
- compilenv -> rec_flag -> (pattern * expression) list ->
- compilenv * (lambda -> lambda)
-val transl_primitive: primitive_description -> lambda
-val transl_exception: Ident.t -> exception_declaration -> lambda
-
-type error =
- Illegal_letrec_pat
- | Illegal_letrec_expr
-
-exception Error of Location.t * error
-
-val report_error: error -> unit
-
-
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
deleted file mode 100644
index 5509868950..0000000000
--- a/bytecomp/translmod.ml
+++ /dev/null
@@ -1,157 +0,0 @@
-(* Translation from typed abstract syntax to lambda terms,
- for the module language *)
-
-open Misc
-open Typedtree
-open Lambda
-open Translcore
-
-
-(* Compile a coercion *)
-
-let rec apply_coercion restr arg =
- match restr with
- Tcoerce_none ->
- arg
- | Tcoerce_structure pos_cc_list ->
- name_lambda arg (fun id ->
- Lprim(Pmakeblock 0, List.map (apply_coercion_field id) pos_cc_list))
- | Tcoerce_functor(cc_arg, cc_res) ->
- let param = Ident.new "funarg" in
- name_lambda arg (fun id ->
- Lfunction(param,
- apply_coercion cc_res
- (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)]))))
-
-and apply_coercion_field id (pos, cc) =
- apply_coercion cc (Lprim(Pfield pos, [Lvar id]))
-
-(* Compose two coercions
- apply_coercion c1 (apply_coercion c2 e) behaves like
- apply_coercion (compose_coercions c1 c2) e. *)
-
-let rec compose_coercions c1 c2 =
- match (c1, c2) with
- (Tcoerce_none, c2) -> c2
- | (c1, Tcoerce_none) -> c1
- | (Tcoerce_structure pc1, Tcoerce_structure pc2) ->
- let v2 = Array.of_list pc2 in
- Tcoerce_structure
- (List.map (fun (p1, c1) ->
- let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2))
- pc1)
- | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) ->
- Tcoerce_functor(compose_coercions arg2 arg1,
- compose_coercions res1 res2)
- | (_, _) ->
- fatal_error "Translmod.compose_coercions"
-
-(* Compile a module expression *)
-
-let rec transl_module env cc mexp =
- match mexp.mod_desc with
- Tmod_ident path ->
- apply_coercion cc (transl_path path)
- | Tmod_structure str ->
- transl_structure env [] cc str
- | Tmod_functor(param, mty, body) ->
- begin match cc with
- Tcoerce_none ->
- Lfunction(param, transl_module env Tcoerce_none body)
- | Tcoerce_functor(ccarg, ccres) ->
- let param' = Ident.new "funarg" in
- Lfunction(param',
- Llet(param, apply_coercion ccarg (Lvar param'),
- transl_module env ccres body))
- | Tcoerce_structure _ ->
- fatal_error "Translmod.transl_module"
- end
- | Tmod_apply(funct, arg, ccarg) ->
- apply_coercion cc
- (Lapply(transl_module env Tcoerce_none funct,
- [transl_module env ccarg arg]))
- | Tmod_constraint(arg, mty, ccarg) ->
- transl_module env (compose_coercions cc ccarg) arg
-
-and transl_structure env fields cc = function
- [] ->
- begin match cc with
- Tcoerce_none ->
- Lprim(Pmakeblock 0,
- List.map (fun id -> transl_access env id) (List.rev fields))
- | Tcoerce_structure pos_cc_list ->
- let v = Array.of_list (List.rev fields) in
- Lprim(Pmakeblock 0,
- List.map (fun (pos, cc) ->
- apply_coercion cc (transl_access env v.(pos)))
- pos_cc_list)
- | Tcoerce_functor(_, _) ->
- fatal_error "Translmod.transl_structure"
- end
- | Tstr_eval expr :: rem ->
- Lsequence(transl_exp env expr, transl_structure env fields cc rem)
- | Tstr_value(rec_flag, pat_expr_list) :: rem ->
- let ext_fields = let_bound_idents pat_expr_list @ fields in
- let (ext_env, add_let) = transl_let env rec_flag pat_expr_list in
- add_let(transl_structure ext_env ext_fields cc rem)
- | Tstr_primitive(id, descr) :: rem ->
- Llet(id, transl_primitive descr.val_prim,
- transl_structure env (id :: fields) cc rem)
- | Tstr_type(decls) :: rem ->
- transl_structure env fields cc rem
- | Tstr_exception(id, decl) :: rem ->
- Llet(id, transl_exception id decl,
- transl_structure env (id :: fields) cc rem)
- | Tstr_module(id, modl) :: rem ->
- Llet(id, transl_module env Tcoerce_none modl,
- transl_structure env (id :: fields) cc rem)
- | Tstr_modtype(id, decl) :: rem ->
- transl_structure env fields cc rem
- | Tstr_open path :: rem ->
- transl_structure env fields cc rem
-
-(* Compile an implementation *)
-
-let transl_implementation module_name str cc =
- let module_id = Ident.new_persistent module_name in
- Lprim(Psetglobal module_id, [transl_structure empty_env [] cc str])
-
-(* Compile a sequence of expressions *)
-
-let rec make_sequence fn = function
- [] -> lambda_unit
- | [x] -> fn x
- | x::rem -> Lsequence(fn x, make_sequence fn rem)
-
-(* Compile a toplevel phrase *)
-
-let transl_toplevel_item = function
- Tstr_eval expr ->
- transl_exp empty_env expr
- | Tstr_value(rec_flag, pat_expr_list) ->
- let idents = let_bound_idents pat_expr_list in
- let (env, add_lets) = transl_let empty_env rec_flag pat_expr_list in
- let lam =
- add_lets(make_sequence
- (fun id -> Lprim(Psetglobal id, [transl_access env id]))
- idents) in
- List.iter Ident.make_global idents;
- lam
- | Tstr_primitive(id, descr) ->
- Ident.make_global id;
- Lprim(Psetglobal id, [transl_primitive descr.val_prim])
- | Tstr_type(decls) ->
- lambda_unit
- | Tstr_exception(id, decl) ->
- Ident.make_global id;
- Lprim(Psetglobal id, [transl_exception id decl])
- | Tstr_module(id, modl) ->
- Ident.make_global id;
- Lprim(Psetglobal id, [transl_module empty_env Tcoerce_none modl])
- | Tstr_modtype(id, decl) ->
- lambda_unit
- | Tstr_open path ->
- lambda_unit
-
-let transl_toplevel_definition str =
- make_sequence transl_toplevel_item str
diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
deleted file mode 100644
index 067b2b6db6..0000000000
--- a/bytecomp/translmod.mli
+++ /dev/null
@@ -1,8 +0,0 @@
-(* Translation from typed abstract syntax to lambda terms,
- for the module language *)
-
-open Typedtree
-open Lambda
-
-val transl_implementation: string -> structure -> module_coercion -> lambda
-val transl_toplevel_definition: structure -> lambda
View Lorry Controller Status