summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--asmcomp/Makefile91
-rw-r--r--asmcomp/lexcmm.mli10
-rw-r--r--asmcomp/main.ml17
-rw-r--r--asmcomp/parsecmmaux.ml26
-rw-r--r--asmcomp/parsecmmaux.mli12
-rw-r--r--asmcomp/sequence.ml354
-rw-r--r--asmcomp/sequence.mli4
-rw-r--r--asmrun/compare.c65
-rw-r--r--asmrun/debug.c135
-rw-r--r--asmrun/gc.c295
-rw-r--r--asmrun/i386.asm172
-rw-r--r--asmrun/misc.h5
-rw-r--r--asmrun/mlvalues.h36
-rw-r--r--asmrun/runtime.c51
-rw-r--r--bytecomp/codegen.ml444
-rw-r--r--bytecomp/codegen.mli8
-rw-r--r--bytecomp/librarian.ml62
-rw-r--r--bytecomp/librarian.mli18
-rw-r--r--bytecomp/linker.ml262
-rw-r--r--bytecomp/linker.mli16
-rw-r--r--byterun/oldlexing.c90
-rw-r--r--stdlib/baltree.ml193
-rw-r--r--stdlib/baltree.mli77
-rw-r--r--test/Results/runtest1
-rwxr-xr-xtools/convert233
-rw-r--r--utils/cset.ml103
-rw-r--r--utils/cset.mli9
-rw-r--r--utils/meta.ml7
-rw-r--r--utils/meta.mli9
29 files changed, 0 insertions, 2805 deletions
diff --git a/asmcomp/Makefile b/asmcomp/Makefile
deleted file mode 100644
index dc70e91312..0000000000
--- a/asmcomp/Makefile
+++ /dev/null
@@ -1,91 +0,0 @@
-ARCH=alpha
-
-include ../Makefile.config
-
-CAMLC=cslc
-COMPFLAGS=$(INCLUDES)
-LINKFLAGS=
-CAMLYACC=cslyacc
-YACCFLAGS=
-CAMLLEX=csllex
-CAMLDEP=../tools/camldep
-DEPFLAGS=$(INCLUDES)
-CAMLRUN=cslrun
-
-INCLUDES=-I ../utils -I ../typing
-
-UTILS=../utils/misc.cmo ../utils/tbl.cmo ../typing/ident.cmo
-
-OBJS=arch.cmo cmm.cmo printcmm.cmo \
- reg.cmo mach.cmo proc.cmo printmach.cmo \
- selection.cmo sequence.cmo liveness.cmo spill.cmo split.cmo \
- interf.cmo coloring.cmo reload.cmo linearize.cmo printlinear.cmo \
- emitaux.cmo emit.cmo \
- parsecmmaux.cmo parsecmm.cmo lexcmm.cmo \
- codegen.cmo main.cmo
-
-codegen: $(OBJS)
- $(CAMLC) $(LINKFLAGS) -o codegen $(UTILS) $(OBJS)
-clean::
- rm -f codegen
-
-# Choose the right arch, emit and proc files
-
-arch.ml: arch_$(ARCH).ml
- ln -s arch_$(ARCH).ml arch.ml
-clean::
- rm -f arch.ml
-beforedepend:: arch.ml
-
-proc.ml: proc_$(ARCH).ml
- ln -s proc_$(ARCH).ml proc.ml
-clean::
- rm -f proc.ml
-beforedepend:: proc.ml
-
-# Preprocess the code emitters
-
-emit.ml: emit_$(ARCH).mlp ../tools/cvt_emit
- ../tools/cvt_emit emit_$(ARCH).mlp > emit.ml || rm -f emit.ml
-clean::
- rm -f emit.ml
-
-beforedepend:: emit.ml
-
-# The parser
-
-parsecmm.mli parsecmm.ml: parsecmm.mly
- $(CAMLYACC) $(YACCFLAGS) parsecmm.mly
-
-clean::
- rm -f parsecmm.mli parsecmm.ml parsecmm.output
-
-beforedepend:: parsecmm.mli parsecmm.ml
-
-# The lexer
-
-lexcmm.ml: lexcmm.mll
- $(CAMLLEX) lexcmm.mll
-
-clean::
- rm -f lexcmm.ml
-
-beforedepend:: lexcmm.ml
-
-# Default rules
-
-.SUFFIXES: .ml .mli .cmo .cmi
-
-.ml.cmo:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.mli.cmi:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-clean::
- rm -f *.cm[io] *~
-
-depend: beforedepend
- $(CAMLDEP) $(DEPFLAGS) *.mli *.ml > .depend
-
-include .depend
diff --git a/asmcomp/lexcmm.mli b/asmcomp/lexcmm.mli
deleted file mode 100644
index f9fe6afadf..0000000000
--- a/asmcomp/lexcmm.mli
+++ /dev/null
@@ -1,10 +0,0 @@
-val token: Lexing.lexbuf -> Parsecmm.token
-
-type error =
- Illegal_character
- | Unterminated_comment
- | Unterminated_string
-
-exception Error of error
-
-val report_error: Lexing.lexbuf -> error -> unit
diff --git a/asmcomp/main.ml b/asmcomp/main.ml
deleted file mode 100644
index f912a8d212..0000000000
--- a/asmcomp/main.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-let main() =
- Arg.parse
- ["-dcmm", Arg.Unit(fun () -> Codegen.dump_cmm := true);
- "-dsel", Arg.Unit(fun () -> Codegen.dump_selection := true);
- "-dlive", Arg.Unit(fun () -> Codegen.dump_live := true;
- Printmach.print_live := true);
- "-dspill", Arg.Unit(fun () -> Codegen.dump_spill := true);
- "-dsplit", Arg.Unit(fun () -> Codegen.dump_split := true);
- "-dinterf", Arg.Unit(fun () -> Codegen.dump_interf := true);
- "-dprefer", Arg.Unit(fun () -> Codegen.dump_prefer := true);
- "-dalloc", Arg.Unit(fun () -> Codegen.dump_regalloc := true);
- "-dreload", Arg.Unit(fun () -> Codegen.dump_reload := true);
- "-dlinear", Arg.Unit(fun () -> Codegen.dump_linear := true)]
- Codegen.file
-
-let _ = Printexc.catch main (); exit 0
-
diff --git a/asmcomp/parsecmmaux.ml b/asmcomp/parsecmmaux.ml
deleted file mode 100644
index d41d2b71cc..0000000000
--- a/asmcomp/parsecmmaux.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-(* Auxiliary functions for parsing *)
-
-type error =
- Unbound of string
-
-exception Error of error
-
-let tbl_ident = (Hashtbl.new 57 : (string, Ident.t) Hashtbl.t)
-
-let bind_ident s =
- let id = Ident.new s in
- Hashtbl.add tbl_ident s id;
- id
-
-let find_ident s =
- try
- Hashtbl.find tbl_ident s
- with Not_found ->
- raise(Error(Unbound s))
-
-let unbind_ident id =
- Hashtbl.remove tbl_ident (Ident.name id)
-
-let report_error = function
- Unbound s ->
- prerr_string "Unbound identifier "; prerr_string s; prerr_endline "."
diff --git a/asmcomp/parsecmmaux.mli b/asmcomp/parsecmmaux.mli
deleted file mode 100644
index c7920803ae..0000000000
--- a/asmcomp/parsecmmaux.mli
+++ /dev/null
@@ -1,12 +0,0 @@
-(* Auxiliary functions for parsing *)
-
-val bind_ident: string -> Ident.t
-val find_ident: string -> Ident.t
-val unbind_ident: Ident.t -> unit
-
-type error =
- Unbound of string
-
-exception Error of error
-
-val report_error: error -> unit
diff --git a/asmcomp/sequence.ml b/asmcomp/sequence.ml
deleted file mode 100644
index b8bcbf4f39..0000000000
--- a/asmcomp/sequence.ml
+++ /dev/null
@@ -1,354 +0,0 @@
-(* "Sequentialization": from C-- to sequences of pseudo-instructions
- with pseudo-registers. *)
-
-open Misc
-open Cmm
-open Reg
-open Selection
-open Mach
-
-(* Naming of registers *)
-
-let all_regs_anonymous rv =
- try
- for i = 0 to Array.length rv - 1 do
- if String.length rv.(i).name > 0 then raise Exit
- done;
- true
- with Exit ->
- false
-
-let name_regs id rv =
- if Array.length rv = 1 then
- rv.(0).name <- Ident.name id
- else
- for i = 0 to Array.length rv - 1 do
- rv.(i).name <- Ident.name id ^ "#" ^ string_of_int i
- done
-
-(* Buffering of instruction sequences *)
-
-type instruction_sequence = instruction ref
-
-let new_sequence() = ref dummy_instr
-
-let insert desc arg res seq =
- seq := instr_cons desc arg res !seq
-
-let extract_sequence seq =
- let rec extract res i =
- if i == dummy_instr
- then res
- else extract (instr_cons i.desc i.arg i.res res) i.next in
- extract (end_instr()) !seq
-
-(* Insert a sequence of moves from one pseudoreg set to another. *)
-
-let insert_moves src dst seq =
- for i = 0 to Array.length src - 1 do
- if src.(i).stamp <> dst.(i).stamp then
- insert (Iop Imove) [|src.(i)|] [|dst.(i)|] seq
- done
-
-(* Insert moves and stackstores for function arguments and function results *)
-
-let insert_move_args arg loc stacksize seq =
- if stacksize <> 0 then insert (Iop(Istackoffset stacksize)) [||] [||] seq;
- insert_moves arg loc seq
-
-let insert_move_results loc res stacksize seq =
- if stacksize <> 0 then insert(Iop(Istackoffset(-stacksize))) [||] [||] seq;
- insert_moves loc res seq
-
-(* "Join" two instruction sequences, making sure they return their results
- in the same registers. *)
-
-let join r1 seq1 r2 seq2 =
- if Array.length r1 = 0 then r2
- else if Array.length r2 = 0 then r1
- else begin insert_moves r2 r1 seq2; r1 end
-
-(* Same, for N branches *)
-
-let join_array rs =
- let dest = ref [||] in
- for i = 0 to Array.length rs - 1 do
- let (r, s) = rs.(i) in
- if Array.length r > 0 then dest := r
- done;
- if Array.length !dest > 0 then
- for i = 0 to Array.length rs - 1 do
- let (r, s) = rs.(i) in
- if Array.length r > 0 then insert_moves r !dest s
- done;
- !dest
-
-(* Add the instructions for the given expression
- at the end of the given sequence *)
-
-let rec emit_expr env exp seq =
- match exp with
- Sconst c ->
- let ty =
- match c with
- Const_int n -> typ_int
- | Const_float f -> typ_float
- | Const_symbol s -> typ_addr
- | Const_pointer n -> typ_addr in
- let r = Reg.newv ty in
- insert (Iop(Iconstant c)) [||] r seq;
- r
- | Svar v ->
- begin try
- Tbl.find v env
- with Not_found ->
- fatal_error("Sequence.emit_expr: unbound var " ^ Ident.name v)
- end
- | Slet(v, e1, e2) ->
- emit_expr (emit_let env v e1 seq) e2 seq
- | Sassign(v, e1) ->
- let rv =
- try
- Tbl.find v env
- with Not_found ->
- fatal_error ("Sequence.emit_expr: unbound var " ^ Ident.name v) in
- let r1 = emit_expr env e1 seq in
- insert_moves r1 rv seq;
- [||]
- | Stuple(ev, perm) ->
- let rv = Array.new (Array.length ev) [||] in
- List.iter (fun i -> rv.(i) <- emit_expr env ev.(i) seq) perm;
- Array.concat(Array.to_list rv)
- | Sop(Icall_ind, e1, ty) ->
- Proc.contains_calls := true;
- let r1 = emit_expr env e1 seq in
- let rarg = Array.sub r1 1 (Array.length r1 - 1) in
- let rd = Reg.newv ty in
- let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
- let loc_res = Proc.loc_results rd in
- insert_move_args rarg loc_arg stack_ofs seq;
- insert (Iop Icall_ind) (Array.append [|r1.(0)|] loc_arg) loc_res seq;
- insert_move_results loc_res rd stack_ofs seq;
- rd
- | Sop(Icall_imm lbl, e1, ty) ->
- Proc.contains_calls := true;
- let r1 = emit_expr env e1 seq in
- let rd = Reg.newv ty in
- let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
- let loc_res = Proc.loc_results rd in
- insert_move_args r1 loc_arg stack_ofs seq;
- insert (Iop(Icall_imm lbl)) loc_arg loc_res seq;
- insert_move_results loc_res rd stack_ofs seq;
- rd
- | Sop(Iextcall lbl, e1, ty) ->
- Proc.contains_calls := true;
- let r1 = emit_expr env e1 seq in
- let rd = Reg.newv ty in
- let (loc_arg, stack_ofs) = Proc.loc_external_arguments r1 in
- let loc_res = Proc.loc_external_results rd in
- insert_move_args r1 loc_arg stack_ofs seq;
- insert (Iop(Iextcall lbl)) loc_arg loc_res seq;
- insert_move_results loc_res rd stack_ofs seq;
- rd
- | Sop(Iload(Word, addr), e1, ty) ->
- let r1 = emit_expr env e1 seq in
- let rd = Reg.newv ty in
- let a = ref addr in
- for i = 0 to Array.length ty - 1 do
- insert(Iop(Iload(Word, !a))) r1 [|rd.(i)|] seq;
- a := Arch.offset_addressing !a (size_component ty.(i))
- done;
- rd
- | Sop(Istore(Word, addr), e1, _) ->
- let r1 = emit_expr env e1 seq in
- let na = Arch.num_args_addressing addr in
- let ra = Array.sub r1 0 na in
- let a = ref addr in
- for i = na to Array.length r1 - 1 do
- insert(Iop(Istore(Word, !a))) (Array.append [|r1.(i)|] ra) [||] seq;
- a := Arch.offset_addressing !a (size_component r1.(i).typ)
- done;
- [||]
- | Sop(Ialloc _, e1, _) ->
- Proc.contains_calls := true;
- let r1 = emit_expr env e1 seq in
- let rd = Reg.newv typ_addr in
- insert (Iop(Ialloc(Cmm.size_machtype(Array.map (fun r -> r.typ) r1))))
- [||] rd seq;
- let a =
- ref (Arch.offset_addressing Arch.identity_addressing
- (-Arch.size_int)) in
- for i = 0 to Array.length r1 - 1 do
- insert(Iop(Istore(Word, !a))) [|r1.(i); rd.(0)|] [||] seq;
- a := Arch.offset_addressing !a (size_component r1.(i).typ)
- done;
- rd
- | Sop(op, e1, ty) ->
- begin match op with
- Imodify -> Proc.contains_calls := true | _ -> ()
- end;
- let r1 = emit_expr env e1 seq in
- let rd = Reg.newv ty in
- begin try
- (* Offer the processor description an opportunity to insert moves
- before and after the operation, i.e. for two-address instructions,
- or instructions using dedicated registers. *)
- let (rsrc, rdst) = Proc.pseudoregs_for_operation op r1 rd in
- insert_moves r1 rsrc seq;
- insert (Iop op) rsrc rdst seq;
- insert_moves rdst rd seq
- with Proc.Use_default ->
- (* Assume no constraints on arg and res registers *)
- insert (Iop op) r1 rd seq
- end;
- rd
- | Sproj(e1, ofs, len) ->
- let r1 = emit_expr env e1 seq in
- Array.sub r1 ofs len
- | Ssequence(e1, e2) ->
- emit_expr env e1 seq;
- emit_expr env e2 seq
- | Sifthenelse(cond, earg, eif, eelse) ->
- let rarg = emit_expr env earg seq in
- let (rif, sif) = emit_sequence env eif in
- let (relse, selse) = emit_sequence env eelse in
- let r = join rif sif relse selse in
- insert (Iifthenelse(cond, extract_sequence sif, extract_sequence selse))
- rarg [||] seq;
- r
- | Sswitch(esel, index, ecases) ->
- let rsel = emit_expr env esel seq in
- let rscases = Array.map (emit_sequence env) ecases in
- let r = join_array rscases in
- insert (Iswitch(index,
- Array.map (fun (r, s) -> extract_sequence s) rscases))
- rsel [||] seq;
- r
- | Sloop(ebody) ->
- let (rarg, sbody) = emit_sequence env ebody in
- insert (Iloop(extract_sequence sbody)) [||] [||] seq;
- [||]
- | Scatch(e1, e2) ->
- let (r1, s1) = emit_sequence env e1 in
- let (r2, s2) = emit_sequence env e2 in
- let r = join r1 s1 r2 s2 in
- insert (Icatch(extract_sequence s1, extract_sequence s2)) [||] [||] seq;
- r
- | Sexit ->
- insert Iexit [||] [||] seq;
- [||]
- | Strywith(e1, v, e2) ->
- let (r1, s1) = emit_sequence env e1 in
- let rv = Reg.newv typ_addr in
- let (r2, s2) = emit_sequence (Tbl.add v rv env) e2 in
- let r = join r1 s1 r2 s2 in
- insert
- (Itrywith(extract_sequence s1,
- instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv
- (extract_sequence s2)))
- [||] [||] seq;
- r
- | Sraise e1 ->
- let r1 = emit_expr env e1 seq in
- insert Iraise r1 [||] seq;
- [||]
-
-and emit_sequence env exp =
- let seq = new_sequence() in
- let r = emit_expr env exp seq in
- (r, seq)
-
-and emit_let env v e1 seq =
- let r1 = emit_expr env e1 seq in
- if all_regs_anonymous r1 then begin
- name_regs v r1;
- Tbl.add v r1 env
- end else begin
- let rv = Array.new (Array.length r1) Reg.dummy in
- for i = 0 to Array.length r1 - 1 do rv.(i) <- Reg.new r1.(i).typ done;
- name_regs v rv;
- insert_moves r1 rv seq;
- Tbl.add v rv env
- end
-
-(* Same, but in tail position *)
-
-let emit_return env exp seq =
- let r = emit_expr env exp seq in
- let loc = Proc.loc_results r in
- insert_moves r loc seq;
- insert Ireturn loc [||] seq
-
-let rec emit_tail env exp seq =
- match exp with
- Slet(v, e1, e2) ->
- emit_tail (emit_let env v e1 seq) e2 seq
- | Sop(Icall_ind, e1, ty) ->
- let r1 = emit_expr env e1 seq in
- let rarg = Array.sub r1 1 (Array.length r1 - 1) in
- let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
- if stack_ofs <> 0 then
- emit_return env exp seq
- else begin
- insert_moves rarg loc_arg seq;
- insert (Iop Itailcall_ind) (Array.append [|r1.(0)|] loc_arg) [||] seq
- end
- | Sop(Icall_imm lbl, e1, ty) ->
- let r1 = emit_expr env e1 seq in
- let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
- if stack_ofs <> 0 then
- emit_return env exp seq
- else begin
- insert_moves r1 loc_arg seq;
- insert (Iop(Itailcall_imm lbl)) loc_arg [||] seq
- end
- | Ssequence(e1, e2) ->
- emit_expr env e1 seq;
- emit_tail env e2 seq
- | Sifthenelse(cond, earg, eif, eelse) ->
- let rarg = emit_expr env earg seq in
- insert (Iifthenelse(cond, emit_tail_sequence env eif,
- emit_tail_sequence env eelse))
- rarg [||] seq
- | Sswitch(esel, index, ecases) ->
- let rsel = emit_expr env esel seq in
- insert (Iswitch(index, Array.map (emit_tail_sequence env) ecases))
- rsel [||] seq
- | Scatch(e1, e2) ->
- insert (Icatch(emit_tail_sequence env e1, emit_tail_sequence env e2))
- [||] [||] seq
- | Sexit ->
- insert Iexit [||] [||] seq
- | Sraise e1 ->
- let r1 = emit_expr env e1 seq in
- let rd = [|Proc.loc_exn_bucket|] in
- insert (Iop Imove) r1 rd seq;
- insert Iraise rd [||] seq
- | _ ->
- emit_return env exp seq
-
-and emit_tail_sequence env exp =
- let seq = new_sequence() in
- emit_tail env exp seq;
- extract_sequence seq
-
-(* Sequentialization of a function definition *)
-
-let fundecl f =
- Proc.contains_calls := false;
- let rargs =
- List.map
- (fun (id, ty) -> let r = Reg.newv ty in name_regs id r; r)
- f.Cmm.fun_args in
- let rarg = Array.concat rargs in
- let loc_arg = Proc.loc_parameters rarg in
- let env =
- List.fold_right2
- (fun (id, ty) r env -> Tbl.add id r env)
- f.Cmm.fun_args rargs Tbl.empty in
- let seq = new_sequence() in
- insert_moves loc_arg rarg seq;
- emit_tail env (Selection.expression f.Cmm.fun_body) seq;
- { fun_name = f.Cmm.fun_name;
- fun_args = loc_arg;
- fun_body = extract_sequence seq }
diff --git a/asmcomp/sequence.mli b/asmcomp/sequence.mli
deleted file mode 100644
index e50c0edc65..0000000000
--- a/asmcomp/sequence.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-(* "Sequentialization": from C-- to sequences of pseudo-instructions
- with pseudo-registers. *)
-
-val fundecl: Cmm.fundecl -> Mach.fundecl
diff --git a/asmrun/compare.c b/asmrun/compare.c
deleted file mode 100644
index 2b10ccf4a8..0000000000
--- a/asmrun/compare.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include <stdio.h>
-#include "mlvalues.h"
-
-value equal(v1, v2)
- value v1, v2;
-{
- header_t hdr1, hdr2;
- long size, i;
-
- tailcall:
- if (v1 == v2) return Val_true;
- if (v1 & 1) return Val_false;
- if (v1 & 1) return Val_false;
- hdr1 = Header_val(v1) & ~Modified_mask;
- hdr2 = Header_val(v2) & ~Modified_mask;
- switch(Tag_header(hdr1)) {
- case Closure_tag:
- case Infix_tag:
- fprintf(stderr, "equal between functions\n");
- exit(2);
- case String_tag:
- if (hdr1 != hdr2) return Val_false;
- size = Size_header(hdr1);
- for (i = 0; i < size; i++)
- if (Field(v1, i) != Field(v2, i)) return Val_false;
- return Val_true;
- case Double_tag:
- if (Double_val(v1) == Double_val(v2))
- return Val_true;
- else
- return Val_false;
- case Abstract_tag:
- case Finalized_tag:
- fprintf(stderr, "equal between abstract types\n");
- exit(2);
- default:
- if (hdr1 != hdr2) return Val_false;
- size = Size_header(hdr1);
- for (i = 0; i < size-1; i++)
- if (equal(Field(v1, i), Field(v2, i)) == Val_false) return Val_false;
- v1 = Field(v1, i);
- v2 = Field(v2, i);
- goto tailcall;
- }
-}
-
-value notequal(v1, v2)
- value v1, v2;
-{
- return (4 - equal(v1, v2));
-}
-
-#define COMPARISON(name) \
-value name(v1, v2) \
- value v1, v2; \
-{ \
- fprintf(stderr, "%s not implemented.\n", #name); \
- exit(2); \
-}
-
-COMPARISON(greaterequal)
-COMPARISON(lessequal)
-COMPARISON(greaterthan)
-COMPARISON(lessthan)
-
diff --git a/asmrun/debug.c b/asmrun/debug.c
deleted file mode 100644
index ef22b08933..0000000000
--- a/asmrun/debug.c
+++ /dev/null
@@ -1,135 +0,0 @@
-#include <stdio.h>
-#include "misc.h"
-#include "mlvalues.h"
-
-char * young_start, * young_ptr, * young_end;
-char * old_start, * old_ptr, * old_end;
-value ** remembered_start, ** remembered_ptr, ** remembered_end;
-
-void failed_assert(file, line)
- char * file;
- int line;
-{
- fprintf(stderr, "Failed assertion, file %s, line %d\n", file, line);
- exit(2);
-}
-
-extern unsigned long _etext;
-long current_break;
-
-/* Check that an object is (reasonably) well-formed */
-
-#define MAX_SIZE 63
-#define MAX_TAG 1
-
-void check_field(v)
- value v;
-{
- if (Is_int(v)) return;
- Assert((v & (sizeof(value) - 1)) == 0);
- Assert(v >= (long) &_etext && v <= (long) current_break);
- if ((char *)v > young_start && (char *)v <= young_end) {
- Assert((char *)v > young_ptr);
- }
-}
-
-void check_value(v)
- value v;
-{
- header_t hdr, sz;
- int i;
-
- if (Is_int(v)) return;
- check_field(v);
- hdr = Header_val(v);
- sz = Size_val(v);
- Assert((hdr & 0x300) == 0);
- switch(Tag_header(hdr)) {
- case Double_tag:
- Assert(sz == sizeof(double) / sizeof(value));
- break;
- case String_tag:
- i = ((char *)v)[sz * sizeof(value) - 1];
- Assert(i >= 0 && i < sizeof(value));
- Assert(((char *)v)[sz * sizeof(value) - 1 - i] == 0);
- break;
- case Abstract_tag:
- case Finalized_tag:
- Assert(0);
- break;
- case Infix_tag:
- v -= sz * sizeof(value);
- Assert(Header_val(v) == Closure_tag);
- check_value(v);
- break;
- case Closure_tag:
- Assert(Field(v, 0) < (long)&_etext);
- if (Field(v, 1) == Val_int(1)) {
- i = 2;
- } else {
- Assert(Is_int(Field(v, 1)));
- Assert(Field(v, 2) < (long)&_etext);
- i = 3;
- }
- while(1) {
- hdr = (header_t) Field(v, i);
- if (Tag_header(hdr) != Infix_tag) break;
- i++;
- Assert(Size_header(hdr) == i);
- Assert(Field(v, i) < (long)&_etext);
- i++;
- if (Field(v, i) == Val_int(1)) {
- i++;
- } else {
- Assert(Is_int(Field(v, i)));
- i++;
- Assert(Field(v, i) < (long)&_etext);
- i++;
- }
- }
- for (/*nothing*/; i < sz; i++) check_field(Field(v, i));
- break;
- default:
-#ifdef MAX_SIZE
- Assert(sz <= MAX_SIZE);
-#endif
-#ifdef MAX_TAG
- Assert(Tag_header(hdr) <= MAX_TAG);
-#endif
- for (i = 0; i < sz; i++) check_field(Field(v, i));
- break;
- }
-}
-
-/* Check that a heap chunk is well-formed */
-
-void check_heap(start, end)
- char * start;
- char * end;
-{
- char * p;
- value v;
-
- current_break = sbrk(0);
- p = start;
- while (p < end) {
- v = (value)(p + sizeof(header_t));
- check_value(v);
- p += sizeof(header_t) + Size_val(v) * sizeof(value);
- }
- Assert(p == end);
-}
-
-/* Check the globals */
-
-extern value * caml_globals[];
-
-void check_globals()
-{
- int i;
- current_break = sbrk(0);
- for (i = 0; caml_globals[i] != 0; i++) {
- value v = *(caml_globals[i]);
- if (v != 0) check_value(v);
- }
-}
diff --git a/asmrun/gc.c b/asmrun/gc.c
deleted file mode 100644
index 285c239a10..0000000000
--- a/asmrun/gc.c
+++ /dev/null
@@ -1,295 +0,0 @@
-#include <stdio.h>
-#include <stdlib.h>
-#include "misc.h"
-#include "mlvalues.h"
-
-char * young_start, * young_ptr, * young_end;
-char * old_start, * old_ptr, * old_end;
-value ** remembered_start, ** remembered_ptr, ** remembered_end;
-
-/* Heap initialization */
-
-int young_size = 32 * sizeof(value) * 1024; /* 128K / 256K */
-int old_size = 256 * sizeof(value) * 1024; /* 1M / 2M */
-int remembered_size = 4096;
-
-void init_heap()
-{
- young_start = malloc(young_size);
- old_start = malloc(old_size);
- remembered_start =
- (value **) malloc(remembered_size * sizeof(value *));
- if (young_start == NULL ||
- old_start == NULL ||
- remembered_start == NULL) {
- fprintf(stderr, "Cannot allocate initial heap\n");
- exit(2);
- }
- young_end = young_start + young_size;
- young_ptr = young_end;
- old_end = old_start + old_size;
- old_ptr = old_start;
- remembered_end = remembered_start + remembered_size;
- remembered_ptr = remembered_start;
-}
-
-/* The hashtable of frame descriptors */
-
-typedef struct {
- unsigned long retaddr;
- short frame_size;
- short num_live;
- short live_ofs[1];
-} frame_descr;
-
-static frame_descr ** frame_descriptors = NULL;
-static int frame_descriptors_mask;
-
-#define Hash_retaddr(addr) \
- (((unsigned long)(addr) >> 2) & frame_descriptors_mask)
-
-extern long * caml_frametable[];
-
-static void init_frame_descriptors()
-{
- long num_descr, tblsize, i, j, len;
- long * tbl;
- frame_descr * d;
- unsigned long h;
-
- /* Count the frame descriptors */
- num_descr = 0;
- for (i = 0; caml_frametable[i] != 0; i++)
- num_descr += *(caml_frametable[i]);
-
- /* The size of the hashtable is a power of 2 greater or equal to
- 4 times the number of descriptors */
- tblsize = 4;
- while (tblsize < 4 * num_descr) tblsize *= 2;
-
- /* Allocate the hash table */
- frame_descriptors =
- (frame_descr **) malloc(tblsize * sizeof(frame_descr *));
- for (i = 0; i < tblsize; i++) frame_descriptors[i] = NULL;
- frame_descriptors_mask = tblsize - 1;
-
- /* Fill the hash table */
- for (i = 0; caml_frametable[i] != 0; i++) {
- tbl = caml_frametable[i];
- len = *tbl;
- d = (frame_descr *)(tbl + 1);
- for (j = 0; j < len; j++) {
- h = Hash_retaddr(d->retaddr);
- while (frame_descriptors[h] != NULL) {
- h = (h+1) & frame_descriptors_mask;
- }
- frame_descriptors[h] = d;
- d = (frame_descr *)
- (((unsigned long)d +
- sizeof(char *) + sizeof(short) + sizeof(short) +
- sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
- & -sizeof(frame_descr *));
- }
- }
-}
-
-/* Copy an object (but not its descendents) and overwrite it with
- its new location */
-
-#define Forward_mask 0x100
-
-#if defined(__GNUC__) && !defined(DEBUG)
-static inline
-#else
-static
-#endif
-void copy_obj(addr)
- value * addr;
-{
- value v, res;
- header_t hdr, size, ofs, i;
-
- v = *addr;
- if (Is_int(v) || (char *) v <= young_start || (char *) v > young_end)
- return;
- hdr = Header_val(v);
- if (hdr & Forward_mask) { /* Already copied? */
- res = Field(v, 0); /* Forwarding pointer is in field 0 */
- } else if (Tag_header(hdr) != Infix_tag) {
- size = Size_header(hdr);
- res = (value) (old_ptr + sizeof(header_t));
- old_ptr += sizeof(header_t) + size * sizeof(value);
- Header_val(res) = hdr & ~Modified_mask;
- for (i = 0; i < size; i++)
- Field(res, i) = Field(v, i);
- Header_val(v) = hdr | Forward_mask; /* Set forward mark */
- Field(v, 0) = res; /* Store forwarding pointer */
- } else {
- ofs = Size_header(hdr) * sizeof(value);
- v -= ofs;
- hdr = Header_val(v);
- if (hdr & Forward_mask) {
- res = Field(v, 0);
- } else {
- size = Size_header(hdr);
- res = (value) (old_ptr + sizeof(header_t));
- Header_val(res) = hdr & ~Modified_mask;
- old_ptr += sizeof(header_t) + size * sizeof(value);
- for (i = 0; i < size; i++)
- Field(res, i) = Field(v, i);
- Header_val(v) = hdr | Forward_mask;
- Field(v, 0) = res;
- }
- res += ofs;
- }
- *addr = res;
-}
-
-/* Machine-dependent stack frame accesses */
-
-#ifdef alpha
-#define Saved_return_address(sp) *((long *)(sp - 8))
-#define Already_scanned(sp, retaddr) (retaddr & 1)
-#define Mark_scanned(sp, retaddr) (*((long *)(sp - 8)) = retaddr | 1)
-/** #define Already_scanned(sp, retaddr) 0 **/
-/** #define Mark_scanned(sp, retaddr) **/
-#endif
-
-extern value * caml_globals[];
-extern char * caml_bottom_of_stack, * caml_top_of_stack;
-extern unsigned long caml_last_return_address;
-extern value gc_entry_regs[];
-
-/* Copy everything in the minor heap */
-
-static void minor_collection()
-{
- char * scan_ptr, * sp;
- unsigned long retaddr;
- frame_descr * d;
- unsigned long h;
- int i, n, ofs;
- short * p;
- value v;
- header_t hdr, size;
- value * root, ** rem;
-
- scan_ptr = old_ptr;
-
- /* Copy the global values */
- for (i = 0; caml_globals[i] != 0; i++) copy_obj(caml_globals[i]);
-
- /* Stack roots */
- if (frame_descriptors == NULL) init_frame_descriptors();
- sp = caml_bottom_of_stack;
- retaddr = caml_last_return_address;
-
- while (sp < caml_top_of_stack) {
- /* Find the descriptor corresponding to the return address */
- h = Hash_retaddr(retaddr);
- while(1) {
- d = frame_descriptors[h];
- if (d->retaddr == retaddr) break;
- h = (h+1) & frame_descriptors_mask;
- }
- /* Scan the roots in this frame */
- for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) {
- ofs = *p;
- if (ofs >= 0) {
- Assert(ofs < d->frame_size);
- root = (value *)(sp + ofs);
- } else {
- Assert(ofs >= -32);
- root = &gc_entry_regs[-ofs-1];
- }
- copy_obj(root);
- }
- /* Move to next frame */
- sp += d->frame_size;
- retaddr = Saved_return_address(sp);
- /* Stop here if already scanned */
- if (Already_scanned(sp, retaddr)) break;
- /* Mark frame as already scanned */
- Mark_scanned(sp, retaddr);
- }
-
- /* Scan the remembered set */
- for (rem = remembered_start; rem < remembered_ptr; rem++) {
- v = **rem;
- hdr = Header_val(v);
- if (hdr < No_scan_tag) {
- size = Size_header(hdr);
- for (i = 0; i < size; i++) copy_obj(&Field(v, i));
- }
- Header_val(v) &= ~Modified_mask;
- }
-
- /* Finish the copying */
-
- while (scan_ptr < old_ptr) {
- v = (value) (scan_ptr + sizeof(header_t));
- hdr = Header_val(v);
- size = Size_header(hdr);
- if (Tag_header(hdr) < No_scan_tag) {
- for (i = 0; i < size; i++) copy_obj(&Field(v, i));
- }
- scan_ptr += sizeof(header_t) + size * sizeof(value);
- }
-
- /* Reset allocation pointers */
- young_ptr = young_end;
- remembered_ptr = remembered_start;
-}
-
-/* Garbage collection */
-
-void garbage_collection(request)
- unsigned long request;
-{
- char * initial_old_ptr;
-
- fprintf(stderr, "<"); fflush(stderr);
-#ifdef DEBUG
- Assert(young_ptr <= young_end);
- Assert(young_ptr < young_start);
- Assert(young_ptr + request >= young_start);
- check_globals();
- check_heap(young_ptr + request, young_end);
- check_heap(old_start, old_ptr);
-#endif
- if (old_end - old_ptr < young_size) {
- fprintf(stderr, "reallocating old generation "); fflush(stderr);
- old_start = malloc(old_size);
- if (old_start == NULL) {
- fprintf(stderr, "Cannot extend heap\n");
- exit(2);
- }
- old_end = old_start + old_size;
- old_ptr = old_start;
- }
- initial_old_ptr = old_ptr;
- minor_collection();
-#ifdef DEBUG
- check_globals();
- check_heap(old_start, old_ptr);
-#endif
- young_ptr -= request;
- fprintf(stderr, "%d%%>", ((old_ptr - initial_old_ptr) * 100) / young_size);
- fflush(stderr);
-}
-
-/* Reallocate remembered set */
-
-void realloc_remembered()
-{
- int used = remembered_ptr - remembered_start;
- remembered_size *= 2;
- remembered_start =
- (value **) realloc(remembered_start, remembered_size);
- if (remembered_start == NULL) {
- fprintf(stderr, "Cannot reallocate remembered set\n");
- exit(2);
- }
- remembered_end = remembered_start + remembered_size;
- remembered_ptr = remembered_start + used;
-}
diff --git a/asmrun/i386.asm b/asmrun/i386.asm
deleted file mode 100644
index 50369be9c8..0000000000
--- a/asmrun/i386.asm
+++ /dev/null
@@ -1,172 +0,0 @@
-#*********************************************************************#
-# #
-# Caml Special Light #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1995 Institut National de Recherche en Informatique et #
-# Automatique. Distributed only by permission. #
-# #
-#*********************************************************************#
-
-# $Id$ #
-
-# Asm part of the runtime system, Intel 386 processor
-
- .comm _young_start, 4
- .comm _young_ptr, 4
- .comm _gc_entry_regs, 4 * 7
- .comm _caml_bottom_of_stack, 4
- .comm _caml_top_of_stack, 4
- .comm _caml_last_return_address, 4
- .comm _remembered_ptr, 4
- .comm _remembered_end, 4
- .comm _caml_exception_pointer, 4
-
-# Allocation
-
- .text
- .globl _caml_alloc1
- .globl _caml_alloc2
- .globl _caml_alloc3
- .globl _caml_alloc
- .globl _caml_call_gc
-
- .align 4
-_caml_alloc1:
- movl _young_ptr, %eax
- subl $8, %eax
- movl %eax, _young_ptr
- cmpl _young_start, %eax
- jb L100
- ret
-L100: movl $8, %eax
- jmp L105
-
- .align 4
-_caml_alloc2:
- movl _young_ptr, %eax
- subl $12, %eax
- movl %eax, _young_ptr
- cmpl _young_start, %eax
- jb L101
- ret
-L101: movl $12, %eax
- jmp L105
-
- .align 4
-_caml_alloc3:
- movl _young_ptr, %eax
- subl $16, %eax
- movl %eax, _young_ptr
- cmpl _young_start, %eax
- jb L102
- ret
-L102: movl $16, %eax
- jmp L105
-
- .align 4
-_caml_alloc:
- pushl %eax
- movl _young_ptr, %eax
- subl (%esp), %eax
- movl %eax, _young_ptr
- cmpl _young_start, %eax
- jb L103
- addl $4, %esp
- ret
-L103: popl %eax
- jmp L105
-
-_caml_call_gc:
- # Recover desired size and adjust return address
- popl %eax
- addl $2, %eax
- pushl %eax
- movzwl -2(%eax), %eax
-L105:
- # Record lowest stack address and return address
- popl _caml_last_return_address
- movl %esp, _caml_bottom_of_stack
- # Save all regs used by the code generator
- movl %ebx, _gc_entry_regs + 4
- movl %ecx, _gc_entry_regs + 8
- movl %edx, _gc_entry_regs + 12
- movl %esi, _gc_entry_regs + 16
- movl %edi, _gc_entry_regs + 20
- movl %ebp, _gc_entry_regs + 24
- # Save desired size
- pushl %eax
- # Call the garbage collector
- call _minor_collection
- # Restore all regs used by the code generator
- movl _gc_entry_regs + 4, %ebx
- movl _gc_entry_regs + 8, %ecx
- movl _gc_entry_regs + 12, %edx
- movl _gc_entry_regs + 16, %esi
- movl _gc_entry_regs + 20, %edi
- movl _gc_entry_regs + 24, %ebp
- # Decrement young_ptr by desired size
- popl %eax
- subl %eax, _young_ptr
- # Reload result of allocation in %eax
- movl _young_ptr, %eax
- # Return to caller
- pushl _caml_last_return_address
- ret
-
-# Call a C function from Caml
-
- .globl _caml_c_call
-
- .align 4
-_caml_c_call:
- # Record lowest stack address and return address
- movl (%esp), %edx
- movl %edx, _caml_last_return_address
- leal 4(%esp), %edx
- movl %edx, _caml_bottom_of_stack
- # Free the floating-point register stack
- finit
- # Call the function (address in %eax)
- jmp *%eax
-
-# Start the Caml program
-
- .globl _caml_start_program
- .align 4
-_caml_start_program:
- # Save callee-save registers
- pushl %ebx
- pushl %esi
- pushl %edi
- pushl %ebp
- # Build an exception handler
- pushl $L104
- pushl $0
- movl %esp, _caml_exception_pointer
- # Record highest stack address
- movl %esp, _caml_top_of_stack
- # Go for it
- call _caml_program
- # Pop handler
- addl $8, %esp
- # Zero return code
- xorl %eax, %eax
-L104:
- # Restore registers and return
- popl %ebp
- popl %edi
- popl %esi
- popl %ebx
- ret
-
-# Raise an exception from C
-
- .globl _raise_caml_exception
- .align 4
-_raise_caml_exception:
- movl 4(%esp), %eax
- movl _caml_exception_pointer, %esp
- popl _caml_exception_pointer
- ret
diff --git a/asmrun/misc.h b/asmrun/misc.h
deleted file mode 100644
index edead293c9..0000000000
--- a/asmrun/misc.h
+++ /dev/null
@@ -1,5 +0,0 @@
-#ifdef DEBUG
-#define Assert(x) if(!(x)) failed_assert(__FILE__, __LINE__)
-#else
-#define Assert(x)
-#endif
diff --git a/asmrun/mlvalues.h b/asmrun/mlvalues.h
deleted file mode 100644
index b05a134ac6..0000000000
--- a/asmrun/mlvalues.h
+++ /dev/null
@@ -1,36 +0,0 @@
-typedef long value;
-
-#define Long_val(v) ((v) >> 1)
-#define Val_long(n) (((long)(n) << 1) + 1)
-#define Int_val(v) ((v) >> 1)
-#define Val_int(n) (((n) << 1) + 1)
-
-#define Is_int(v) ((v) & 1)
-#define Is_block(v) (((v) & 1) == 0)
-
-typedef unsigned long header_t;
-
-#define Header_val(v) *((header_t *)(v) - 1)
-#define Tag_header(h) ((h) & 0xFF)
-#define Size_header(h) ((h) >> 11)
-#define Tag_val(v) Tag_header(Header_val(v))
-#define Size_val(v) Size_header(Header_val(v))
-
-#define Field(v, n) (((value *)(v))[n])
-
-#define Double_val(v) *((double *)(v))
-
-#define No_scan_tag 0xFB
-
-#define Closure_tag 0xFA
-#define Double_tag 0xFB
-#define String_tag 0xFC
-#define Abstract_tag 0xFD
-#define Finalized_tag 0xFE
-#define Infix_tag 0xFF
-
-#define Modified_mask 0x400
-
-#define Val_false 1
-#define Val_true 3
-#define Val_unit 1
diff --git a/asmrun/runtime.c b/asmrun/runtime.c
deleted file mode 100644
index b8061b46ca..0000000000
--- a/asmrun/runtime.c
+++ /dev/null
@@ -1,51 +0,0 @@
-/* A very simplified runtime system for the native code compiler */
-
-#include <stdio.h>
-#include <stdlib.h>
-#include "mlvalues.h"
-
-extern int caml_start_program();
-
-value print_int(n)
- value n;
-{
- printf("%d", n>>1);
- return 1;
-}
-
-value print_string(s)
- value s;
-{
- printf("%s", (char *) s);
- return 1;
-}
-
-value print_char(c)
- value c;
-{
- printf("%c", c>>1);
- return 1;
-}
-
-static struct {
- value header;
- char data[16];
-} match_failure_id = {
- ((16 / sizeof(value)) << 11) + 0xFC,
- "Match_failure\0\0\2"
-};
-
-char * Match_failure = match_failure_id.data;
-
-int main(argc, argv)
- int argc;
- char ** argv;
-{
- init_heap();
- if (caml_start_program() != 0) {
- fprintf(stderr, "Uncaught exception\n");
- exit(2);
- }
- return 0;
-}
-
diff --git a/bytecomp/codegen.ml b/bytecomp/codegen.ml
deleted file mode 100644
index 0f2a88f1b1..0000000000
--- a/bytecomp/codegen.ml
+++ /dev/null
@@ -1,444 +0,0 @@
-(* codegen.ml : translation of lambda terms to lists of instructions. *)
-
-open Misc
-open Asttypes
-open Lambda
-open Instruct
-
-(**** Label generation ****)
-
-let label_counter = ref 0
-
-let new_label () =
- incr label_counter; !label_counter
-
-(**** Structure of the compilation environment. ****)
-
-type compilation_env =
- { ce_stack: int Ident.tbl; (* Positions of variables in the stack *)
- ce_heap: int Ident.tbl } (* Structure of the heap-allocated env *)
-
-(* The ce_stack component gives locations of variables residing
- in the stack. The locations are offsets w.r.t. the origin of the
- stack frame.
- The ce_heap component gives the positions of variables residing in the
- heap-allocated environment. *)
-
-let empty_env =
- { ce_stack = Ident.empty; ce_heap = Ident.empty }
-
-(* Add a stack-allocated variable *)
-
-let add_var id pos env =
- { ce_stack = Ident.add id pos env.ce_stack;
- ce_heap = env.ce_heap }
-
-(**** Examination of the continuation ****)
-
-(* Return a label to the beginning of the given continuation.
- If the sequence starts with a branch, use the target of that branch
- as the label, thus avoiding a jump to a jump. *)
-
-let label_code = function
- Kbranch lbl :: _ as cont -> (lbl, cont)
- | Klabel lbl :: _ as cont -> (lbl, cont)
- | cont -> let lbl = new_label() in (lbl, Klabel lbl :: cont)
-
-(* Return a branch to the continuation. That is, an instruction that,
- when executed, branches to the continuation or performs what the
- continuation performs. We avoid generating branches to branches and
- branches to returns. *)
-
-let make_branch cont =
- match cont with
- (Kbranch _ as branch) :: _ -> (branch, cont)
- | (Kreturn _ as return) :: _ -> (return, cont)
- | Kraise :: _ -> (Kraise, cont)
- | Klabel lbl :: _ -> (Kbranch lbl, cont)
- | _ -> let lbl = new_label() in (Kbranch lbl, Klabel lbl :: cont)
-
-(* Discard all instructions up to the next label.
- This function is to be applied to the continuation before adding a
- non-terminating instruction (branch, raise, return) in front of it. *)
-
-let rec discard_dead_code = function
- [] -> []
- | (Klabel _ | Krestart) :: _ as cont -> cont
- | _ :: cont -> discard_dead_code cont
-
-(* Check if we're in tailcall position *)
-
-let rec is_tailcall = function
- Kreturn _ :: _ -> true
- | Klabel _ :: c -> is_tailcall c
- | _ -> false
-
-(* Add a Kpop N instruction in front of a continuation *)
-
-let rec add_pop n cont =
- if n = 0 then cont else
- match cont with
- Kpop m :: cont -> add_pop (n + m) cont
- | Kreturn m :: cont -> Kreturn(n + m) :: cont
- | Kraise :: _ -> cont
- | _ -> Kpop n :: cont
-
-(* Add the constant "unit" in front of a continuation *)
-
-let add_const_unit = function
- (Kacc _ | Kconst _ | Kgetglobal _ | Kpush_retaddr _) :: _ as cont -> cont
- | cont -> Kconst const_unit :: cont
-
-(**** Compilation of a lambda expression ****)
-
-(* The label to which Lstaticfail branches, and the stack size at that point.*)
-
-let lbl_staticfail = ref 0
-and sz_staticfail = ref 0
-
-(* Function bodies that remain to be compiled *)
-
-let functions_to_compile =
- (Stack.new () : (Ident.t * lambda * label * Ident.t list) Stack.t)
-
-(* Compile an expression.
- The value of the expression is left in the accumulator.
- env = compilation environment
- exp = the lambda expression to compile
- sz = current size of the stack frame
- cont = list of instructions to execute afterwards
- Result = list of instructions that evaluate exp, then perform cont. *)
-
-open Format
-
-let rec comp_expr env exp sz cont =
- match exp with
- Lvar id ->
- begin try
- let pos = Ident.find_same id env.ce_stack in
- Kacc(sz - pos) :: cont
- with Not_found ->
- try
- let pos = Ident.find_same id env.ce_heap in
- Kenvacc(pos) :: cont
- with Not_found ->
- Ident.print id; print_newline();
- fatal_error "Codegen.comp_expr: var"
- end
- | Lconst cst ->
- Kconst cst :: cont
- | Lapply(func, args) ->
- let nargs = List.length args in
- if is_tailcall cont then
- comp_args env args sz
- (Kpush :: comp_expr env func (sz + nargs)
- (Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
- else
- if nargs < 4 then
- comp_args env args sz
- (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
- else begin
- let (lbl, cont1) = label_code cont in
- Kpush_retaddr lbl ::
- comp_args env args (sz + 3)
- (Kpush :: comp_expr env func (sz + 3 + nargs)
- (Kapply nargs :: cont1))
- end
- | Lfunction(param, body) ->
- let lbl = new_label() in
- let fv = free_variables exp in
- Stack.push (param, body, lbl, fv) functions_to_compile;
- comp_args env (List.map (fun n -> Lvar n) fv) sz
- (Kclosure(lbl, List.length fv) :: cont)
- | Llet(id, arg, body) ->
- comp_expr env arg sz
- (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1)
- (add_pop 1 cont))
- | Lletrec(([id, Lfunction(param, funct_body), _] as decl), let_body) ->
- let lbl = new_label() in
- let fv = free_variables (Lletrec(decl, lambda_unit)) in
- Stack.push (param, funct_body, lbl, id :: fv) functions_to_compile;
- comp_args env (List.map (fun n -> Lvar n) fv) sz
- (Kclosurerec(lbl, List.length fv) :: Kpush ::
- (comp_expr (add_var id (sz+1) env) let_body (sz+1)
- (add_pop 1 cont)))
- | Lletrec(decl, body) ->
- let ndecl = List.length decl in
- let rec comp_decl new_env sz i = function
- [] ->
- comp_expr new_env body sz (add_pop ndecl cont)
- | (id, exp, blocksize) :: rem ->
- comp_expr new_env exp sz
- (Kpush :: Kacc i :: Kupdate blocksize ::
- comp_decl new_env sz (i-1) rem) in
- let rec comp_init new_env sz = function
- [] ->
- comp_decl new_env sz ndecl decl
- | (id, exp, blocksize) :: rem ->
- Kdummy blocksize :: Kpush ::
- comp_init (add_var id (sz+1) new_env) (sz+1) rem in
- comp_init env sz decl
- | Lprim(Pidentity, [arg]) ->
- comp_expr env arg sz cont
- | Lprim(Pnot, [arg]) ->
- let newcont =
- match cont with
- Kbranchif lbl :: cont1 -> Kbranchifnot lbl :: cont1
- | Kbranchifnot lbl :: cont1 -> Kbranchif lbl :: cont1
- | _ -> Kboolnot :: cont in
- comp_expr env arg sz newcont
- | Lprim(Psequand, [exp1; exp2]) ->
- begin match cont with
- Kbranchifnot lbl :: _ ->
- comp_expr env exp1 sz (Kbranchifnot lbl ::
- comp_expr env exp2 sz cont)
- | Kbranchif lbl :: cont1 ->
- let (lbl2, cont2) = label_code cont1 in
- comp_expr env exp1 sz (Kbranchifnot lbl2 ::
- comp_expr env exp2 sz (Kbranchif lbl :: cont2))
- | _ ->
- let (lbl, cont1) = label_code cont in
- comp_expr env exp1 sz (Kstrictbranchifnot lbl ::
- comp_expr env exp2 sz cont1)
- end
- | Lprim(Psequor, [exp1; exp2]) ->
- begin match cont with
- Kbranchif lbl :: _ ->
- comp_expr env exp1 sz (Kbranchif lbl ::
- comp_expr env exp2 sz cont)
- | Kbranchifnot lbl :: cont1 ->
- let (lbl2, cont2) = label_code cont1 in
- comp_expr env exp1 sz (Kbranchif lbl2 ::
- comp_expr env exp2 sz (Kbranchifnot lbl :: cont2))
- | _ ->
- let (lbl, cont1) = label_code cont in
- comp_expr env exp1 sz (Kstrictbranchif lbl ::
- comp_expr env exp2 sz cont1)
- end
- | Lprim(Praise, [arg]) ->
- comp_expr env arg sz (Kraise :: discard_dead_code cont)
- | Lprim((Paddint | Psubint as prim), [arg; Lconst(Const_base(Const_int n))])
- when n >= immed_min & n <= immed_max ->
- let ofs = if prim == Paddint then n else -n in
- comp_expr env arg sz (Koffsetint ofs :: cont)
- | Lprim(p, args) ->
- let instr =
- match p with
- Pgetglobal id -> Kgetglobal id
- | Psetglobal id -> Ksetglobal id
- | Pintcomp cmp -> Kintcomp cmp
- | Pmakeblock tag -> Kmakeblock(List.length args, tag)
- | Pfield n -> Kgetfield n
- | Psetfield n -> Ksetfield n
- | Pccall(name, n) -> Kccall(name, n)
- | Pnegint -> Knegint
- | Paddint -> Kaddint
- | Psubint -> Ksubint
- | Pmulint -> Kmulint
- | Pdivint -> Kdivint
- | Pmodint -> Kmodint
- | Pandint -> Kandint
- | Porint -> Korint
- | Pxorint -> Kxorint
- | Plslint -> Klslint
- | Plsrint -> Klsrint
- | Pasrint -> Kasrint
- | Poffsetint n -> Koffsetint n
- | Poffsetref n -> Koffsetref n
- | Pnegfloat -> Kccall("neg_float", 1)
- | Paddfloat -> Kccall("add_float", 2)
- | Psubfloat -> Kccall("sub_float", 2)
- | Pmulfloat -> Kccall("mul_float", 2)
- | Pdivfloat -> Kccall("div_float", 2)
- | Pfloatcomp Ceq -> Kccall("eq_float", 2)
- | Pfloatcomp Cneq -> Kccall("neq_float", 2)
- | Pfloatcomp Clt -> Kccall("lt_float", 2)
- | Pfloatcomp Cgt -> Kccall("gt_float", 2)
- | Pfloatcomp Cle -> Kccall("le_float", 2)
- | Pfloatcomp Cge -> Kccall("ge_float", 2)
- | Pgetstringchar -> Kgetstringchar
- | Psetstringchar -> Ksetstringchar
- | Pvectlength -> Kvectlength
- | Pgetvectitem -> Kgetvectitem
- | Psetvectitem -> Ksetvectitem
- | Ptranslate tbl -> Ktranslate tbl
- | _ -> fatal_error "Codegen.comp_expr: prim" in
- comp_args env args sz (instr :: cont)
- | Lcatch(body, Lstaticfail) ->
- comp_expr env body sz cont
- | Lcatch(body, handler) ->
- let (branch1, cont1) = make_branch cont in
- let (lbl_handler, cont2) = label_code (comp_expr env handler sz cont1) in
- let saved_lbl_staticfail = !lbl_staticfail
- and saved_sz_staticfail = !sz_staticfail in
- lbl_staticfail := lbl_handler;
- sz_staticfail := sz;
- let cont3 = comp_expr env body sz (branch1 :: cont2) in
- lbl_staticfail := saved_lbl_staticfail;
- sz_staticfail := saved_sz_staticfail;
- cont3
- | Lstaticfail ->
- add_pop (sz - !sz_staticfail)
- (Kbranch !lbl_staticfail :: discard_dead_code cont)
- | Ltrywith(body, id, handler) ->
- let (branch1, cont1) = make_branch cont in
- let lbl_handler = new_label() in
- Kpushtrap lbl_handler ::
- comp_expr env body (sz+4) (Kpoptrap :: branch1 ::
- Klabel lbl_handler :: Kpush ::
- comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1))
- | Lifthenelse(cond, ifso, ifnot) ->
- comp_binary_test env cond ifso ifnot sz cont
- | Lsequence(exp1, exp2) ->
- comp_expr env exp1 sz (comp_expr env exp2 sz cont)
- | Lwhile(cond, body) ->
- let lbl_loop = new_label() in
- let lbl_test = new_label() in
- Kbranch lbl_test :: Klabel lbl_loop :: Kcheck_signals ::
- comp_expr env body sz
- (Klabel lbl_test ::
- comp_expr env cond sz (Kbranchif lbl_loop :: add_const_unit cont))
- | Lfor(param, start, stop, dir, body) ->
- let lbl_loop = new_label() in
- let lbl_test = new_label() in
- let offset = match dir with Upto -> 1 | Downto -> -1 in
- let comp = match dir with Upto -> Cle | Downto -> Cge in
- comp_expr env start sz
- (Kpush :: comp_expr env stop (sz+1)
- (Kpush :: Kbranch lbl_test ::
- Klabel lbl_loop :: Kcheck_signals ::
- comp_expr (add_var param (sz+1) env) body (sz+2)
- (Kacc 1 :: Koffsetint offset :: Kassign 1 ::
- Klabel lbl_test ::
- Kacc 0 :: Kpush :: Kacc 2 :: Kintcomp comp ::
- Kbranchif lbl_loop ::
- add_const_unit (add_pop 2 cont))))
- | Lswitch(arg, num_consts, consts, num_blocks, blocks) ->
- (* To ensure stack balancing, we must have either sz = !sz_staticfail
- or none of the actv.(i) contains an unguarded Lstaticfail. *)
- let (branch, cont1) = make_branch cont in
- let c = ref (discard_dead_code cont1) in
- let act_consts = Array.new num_consts Lstaticfail in
- List.iter (fun (n, act) -> act_consts.(n) <- act) consts;
- let act_blocks = Array.new num_blocks Lstaticfail in
- List.iter (fun (n, act) -> act_blocks.(n) <- act) blocks;
- let lbl_consts = Array.new num_consts 0 in
- let lbl_blocks = Array.new num_blocks 0 in
- for i = num_blocks - 1 downto 0 do
- let (lbl, c1) =
- label_code(comp_expr env act_blocks.(i) sz (branch :: !c)) in
- lbl_blocks.(i) <- lbl;
- c := discard_dead_code c1
- done;
- for i = num_consts - 1 downto 0 do
- let (lbl, c1) =
- label_code(comp_expr env act_consts.(i) sz (branch :: !c)) in
- lbl_consts.(i) <- lbl;
- c := discard_dead_code c1
- done;
- comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c)
- | Lshared(expr, lblref) ->
- begin match !lblref with
- None ->
- let (lbl, cont1) = label_code(comp_expr env expr sz cont) in
- lblref := Some lbl;
- cont1
- | Some lbl ->
- Kbranch lbl :: discard_dead_code cont
- end
-
-(* Compile a list of arguments [e1; ...; eN] to a primitive operation.
- The values of eN ... e2 are pushed on the stack, e2 at top of stack,
- then e3, then ... The value of e1 is left in the accumulator. *)
-
-and comp_args env argl sz cont =
- comp_expr_list env (List.rev argl) sz cont
-
-and comp_expr_list env exprl sz cont =
- match exprl with
- [] -> cont
- | [exp] -> comp_expr env exp sz cont
- | exp :: rem ->
- comp_expr env exp sz (Kpush :: comp_expr_list env rem (sz+1) cont)
-
-(* Compile an if-then-else test. *)
-
-and comp_binary_test env cond ifso ifnot sz cont =
- let cont_cond =
- if ifnot = Lconst const_unit then begin
- let (lbl_end, cont1) = label_code cont in
- Kbranchifnot lbl_end :: comp_expr env ifso sz cont1
- end else
- if ifso = Lstaticfail & sz = !sz_staticfail then
- Kbranchif !lbl_staticfail :: comp_expr env ifnot sz cont
- else
- if ifnot = Lstaticfail & sz = !sz_staticfail then
- Kbranchifnot !lbl_staticfail :: comp_expr env ifso sz cont
- else begin
- let (branch_end, cont1) = make_branch cont in
- let (lbl_not, cont2) = label_code(comp_expr env ifnot sz cont1) in
- Kbranchifnot lbl_not :: comp_expr env ifso sz (branch_end :: cont2)
- end in
- comp_expr env cond sz cont_cond
-
-(**** Compilation of functions ****)
-
-let comp_function (param, body, entry_lbl, free_vars) cont =
- (* Uncurry the function body *)
- let rec uncurry = function
- Lfunction(param, body) ->
- let (params, final) = uncurry body in (param :: params, final)
- | Lshared(exp, lblref) ->
- uncurry exp
- | exp ->
- ([], exp) in
- let (params, fun_body) =
- uncurry (Lfunction(param, body)) in
- let arity = List.length params in
- let rec pos_args pos delta = function
- [] -> Ident.empty
- | id :: rem -> Ident.add id pos (pos_args (pos+delta) delta rem) in
- let env =
- { ce_stack = pos_args arity (-1) params;
- ce_heap = pos_args 0 1 free_vars } in
- let cont1 =
- comp_expr env fun_body arity (Kreturn arity :: cont) in
- if arity > 1 then
- Krestart :: Klabel entry_lbl :: Kgrab(arity - 1) :: cont1
- else
- Klabel entry_lbl :: cont1
-
-let comp_remainder cont =
- let c = ref cont in
- begin try
- while true do
- c := comp_function (Stack.pop functions_to_compile) !c
- done
- with Stack.Empty ->
- ()
- end;
- !c
-
-(**** Compilation of a lambda phrase ****)
-
-let compile_implementation expr =
- Stack.clear functions_to_compile;
- label_counter := 0;
- lbl_staticfail := 0;
- sz_staticfail := 0;
- let init_code = comp_expr empty_env expr 0 [] in
- if Stack.length functions_to_compile > 0 then begin
- let lbl_init = new_label() in
- Kbranch lbl_init :: comp_remainder (Klabel lbl_init :: init_code)
- end else
- init_code
-
-let compile_phrase expr =
- Stack.clear functions_to_compile;
- label_counter := 0;
- lbl_staticfail := 0;
- sz_staticfail := 0;
- let init_code = comp_expr empty_env expr 0 [Kstop] in
- let fun_code = comp_remainder [] in
- (init_code, fun_code)
-
diff --git a/bytecomp/codegen.mli b/bytecomp/codegen.mli
deleted file mode 100644
index 97cb863e37..0000000000
--- a/bytecomp/codegen.mli
+++ /dev/null
@@ -1,8 +0,0 @@
-(* Generation of bytecode from lambda terms *)
-
-open Lambda
-open Instruct
-
-val compile_implementation: lambda -> instruction list
-val compile_phrase: lambda -> instruction list * instruction list
-
diff --git a/bytecomp/librarian.ml b/bytecomp/librarian.ml
deleted file mode 100644
index 156896e1ae..0000000000
--- a/bytecomp/librarian.ml
+++ /dev/null
@@ -1,62 +0,0 @@
-(* Build libraries of .cmo files *)
-
-open Misc
-open Config
-open Emitcode
-
-type error =
- File_not_found of string
- | Not_an_object_file of string
-
-exception Error of error
-
-let copy_object_file outchan toc name =
- let file_name =
- try
- find_in_path !load_path name
- with Not_found ->
- raise(Error(File_not_found name)) in
- let ic = open_in_bin file_name in
- try
- let buffer = String.create (String.length cmo_magic_number) in
- really_input ic buffer 0 (String.length cmo_magic_number);
- if buffer <> cmo_magic_number then
- raise(Error(Not_an_object_file file_name));
- let compunit_pos = input_binary_int ic in
- seek_in ic compunit_pos;
- let compunit = (input_value ic : compilation_unit) in
- seek_in ic compunit.cu_pos;
- compunit.cu_pos <- pos_out outchan;
- copy_file_chunk ic outchan compunit.cu_codesize;
- close_in ic;
- compunit :: toc
- with x ->
- close_in ic;
- raise x
-
-let create_archive file_list lib_name =
- let outchan = open_out_bin lib_name in
- try
- output_string outchan cma_magic_number;
- let ofs_pos_toc = pos_out outchan in
- output_binary_int outchan 0;
- let toc = List.fold_left (copy_object_file outchan) [] file_list in
- let pos_toc = pos_out outchan in
- output_value outchan toc;
- seek_out outchan ofs_pos_toc;
- output_binary_int outchan pos_toc;
- close_out outchan
- with x ->
- close_out outchan;
- remove_file lib_name;
- raise x
-
-open Format
-
-let report_error = function
- File_not_found name ->
- print_string "Cannot find file "; print_string name
- | Not_an_object_file name ->
- print_string "The file "; print_string name;
- print_string " is not a bytecode object file"
-
diff --git a/bytecomp/librarian.mli b/bytecomp/librarian.mli
deleted file mode 100644
index ee9c9f378e..0000000000
--- a/bytecomp/librarian.mli
+++ /dev/null
@@ -1,18 +0,0 @@
-(* Build libraries of .cmo files *)
-
-(* Format of a library file:
- Obj.magic number (Config.cma_magic_number)
- absolute offset of content table
- blocks of relocatable bytecode
- content table = list of compilation units
-*)
-
-val create_archive: string list -> string -> unit
-
-type error =
- File_not_found of string
- | Not_an_object_file of string
-
-exception Error of error
-
-val report_error: error -> unit
diff --git a/bytecomp/linker.ml b/bytecomp/linker.ml
deleted file mode 100644
index a883491f27..0000000000
--- a/bytecomp/linker.ml
+++ /dev/null
@@ -1,262 +0,0 @@
-(* Link a set of .cmo files and produce a bytecode executable. *)
-
-open Sys
-open Misc
-open Config
-open Emitcode
-
-type error =
- File_not_found of string
- | Not_an_object_file of string
- | Symbol_error of string * Symtable.error
- | Inconsistent_import of string * string * string
- | Custom_runtime
-
-exception Error of error
-
-type link_action =
- Link_object of string * compilation_unit
- (* Name of .cmo file and descriptor of the unit *)
- | Link_archive of string * compilation_unit list
- (* Name of .cma file and descriptors of the units to be linked. *)
-
-(* First pass: determine which units are needed *)
-
-module IdentSet =
- Set.Make(struct
- type t = Ident.t
- let compare = compare
- end)
-
-let missing_globals = ref IdentSet.empty
-
-let is_required (rel, pos) =
- match rel with
- Reloc_setglobal id ->
- IdentSet.mem id !missing_globals
- | _ -> false
-
-let add_required (rel, pos) =
- match rel with
- Reloc_getglobal id ->
- missing_globals := IdentSet.add id !missing_globals
- | _ -> ()
-
-let remove_required (rel, pos) =
- match rel with
- Reloc_setglobal id ->
- missing_globals := IdentSet.remove id !missing_globals
- | _ -> ()
-
-let scan_file tolink obj_name =
- let file_name =
- try
- find_in_path !load_path obj_name
- with Not_found ->
- raise(Error(File_not_found obj_name)) in
- let ic = open_in_bin file_name in
- try
- let buffer = String.create (String.length cmo_magic_number) in
- really_input ic buffer 0 (String.length cmo_magic_number);
- if buffer = cmo_magic_number then begin
- (* This is a .cmo file. It must be linked in any case.
- Read the relocation information to see which modules it
- requires. *)
- let compunit_pos = input_binary_int ic in (* Go to descriptor *)
- seek_in ic compunit_pos;
- let compunit = (input_value ic : compilation_unit) in
- List.iter add_required compunit.cu_reloc;
- Link_object(file_name, compunit) :: tolink
- end
- else if buffer = cma_magic_number then begin
- (* This is an archive file. Each unit contained in it will be linked
- in only if needed. *)
- let pos_toc = input_binary_int ic in (* Go to table of contents *)
- seek_in ic pos_toc;
- let toc = (input_value ic : compilation_unit list) in
- let required =
- List.fold_left
- (fun reqd compunit ->
- if List.exists is_required compunit.cu_reloc
- or !Clflags.link_everything
- then begin
- List.iter remove_required compunit.cu_reloc;
- List.iter add_required compunit.cu_reloc;
- compunit :: reqd
- end else
- reqd)
- [] toc in
- Link_archive(file_name, required) :: tolink
- end
- else raise(Error(Not_an_object_file file_name))
- with x ->
- close_in ic; raise x
-
-(* Second pass: link in the required units *)
-
-(* Consistency check between interfaces *)
-
-let crc_interfaces = (Hashtbl.new 17 : (string, string * int) Hashtbl.t)
-
-let check_consistency file_name cu =
- List.iter
- (fun (name, crc) ->
- try
- let (auth_name, auth_crc) = Hashtbl.find crc_interfaces name in
- if crc <> auth_crc then
- raise(Error(Inconsistent_import(name, file_name, auth_name)))
- with Not_found ->
- Hashtbl.add crc_interfaces name (file_name, crc))
- cu.cu_interfaces
-
-(* Link in a compilation unit *)
-
-let link_compunit outchan inchan file_name compunit =
- check_consistency file_name compunit;
- seek_in inchan compunit.cu_pos;
- let code_block = String.create compunit.cu_codesize in
- really_input inchan code_block 0 compunit.cu_codesize;
- Symtable.patch_object code_block compunit.cu_reloc;
- output outchan code_block 0 compunit.cu_codesize
-
-(* Link in a .cmo file *)
-
-let link_object outchan file_name compunit =
- let inchan = open_in_bin file_name in
- try
- link_compunit outchan inchan file_name compunit;
- close_in inchan
- with
- Symtable.Error msg ->
- close_in inchan; raise(Error(Symbol_error(file_name, msg)))
- | x ->
- close_in inchan; raise x
-
-(* Link in a .cma file *)
-
-let link_archive outchan file_name units_required =
- let inchan = open_in_bin file_name in
- try
- List.iter (link_compunit outchan inchan file_name) units_required;
- close_in inchan
- with
- Symtable.Error msg ->
- close_in inchan; raise(Error(Symbol_error(file_name, msg)))
- | x ->
- close_in inchan; raise x
-
-(* Link in a .cmo or .cma file *)
-
-let link_file outchan = function
- Link_object(file_name, unit) -> link_object outchan file_name unit
- | Link_archive(file_name, units) -> link_archive outchan file_name units
-
-(* Create a bytecode executable file *)
-
-let link_bytecode objfiles exec_name copy_header =
- let objfiles = "stdlib.cma" :: objfiles in
- let tolink =
- List.fold_left scan_file [] (List.rev objfiles) in
- let outchan =
- open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] 0o777
- exec_name in
- try
- (* Copy the header *)
- if copy_header then begin
- try
- let inchan = open_in_bin (find_in_path !load_path "cslheader") in
- copy_file inchan outchan;
- close_in inchan
- with Not_found | Sys_error _ -> ()
- end;
- (* The bytecode *)
- let pos1 = pos_out outchan in
- Symtable.init();
- Hashtbl.clear crc_interfaces;
- List.iter (link_file outchan) tolink;
- (* The final STOP instruction *)
- output_byte outchan Opcodes.opSTOP;
- output_byte outchan 0; output_byte outchan 0; output_byte outchan 0;
- (* The table of global data *)
- let pos2 = pos_out outchan in
- output_compact_value outchan (Symtable.initial_global_table());
- (* The List.map of global identifiers *)
- let pos3 = pos_out outchan in
- Symtable.output_global_map outchan;
- (* The trailer *)
- let pos4 = pos_out outchan in
- output_binary_int outchan (pos2 - pos1);
- output_binary_int outchan (pos3 - pos2);
- output_binary_int outchan (pos4 - pos3);
- output_binary_int outchan 0;
- output_string outchan exec_magic_number;
- close_out outchan
- with x ->
- close_out outchan;
- remove_file exec_name;
- raise x
-
-(* Main entry point (build a custom runtime if needed) *)
-
-let link objfiles =
- if not !Clflags.custom_runtime then
- link_bytecode objfiles !Clflags.exec_name true
- else begin
- let bytecode_name = temp_file "camlcode" "" in
- let prim_name = temp_file "camlprim" ".c" in
- try
- link_bytecode objfiles bytecode_name false;
- Symtable.output_primitives prim_name;
- if Sys.command
- (Printf.sprintf
- "%s -I%s -o %s %s %s -L%s %s -lcamlrun %s"
- Config.c_compiler
- Config.standard_library
- !Clflags.exec_name
- (String.concat " " (List.rev !Clflags.ccopts))
- prim_name
- Config.standard_library
- (String.concat " " (List.rev !Clflags.ccobjs))
- Config.c_libraries)
- <> 0
- or Sys.command ("strip " ^ !Clflags.exec_name) <> 0
- then raise(Error Custom_runtime);
- let oc =
- open_out_gen [Open_wronly; Open_append; Open_binary] 0
- !Clflags.exec_name in
- let ic = open_in_bin bytecode_name in
- copy_file ic oc;
- close_in ic;
- close_out oc;
- remove_file bytecode_name;
- remove_file prim_name
- with x ->
- remove_file bytecode_name;
- remove_file prim_name;
- raise x
- end
-
-(* Error report *)
-
-open Format
-
-let report_error = function
- File_not_found name ->
- print_string "Cannot find file "; print_string name
- | Not_an_object_file name ->
- print_string "The file "; print_string name;
- print_string " is not a bytecode object file"
- | Symbol_error(name, err) ->
- print_string "Error while linking "; print_string name; print_string ":";
- print_space();
- Symtable.report_error err
- | Inconsistent_import(intf, file1, file2) ->
- open_hvbox 0;
- print_string "Files "; print_string file1; print_string " and ";
- print_string file2; print_space();
- print_string "make inconsistent assumptions over interface ";
- print_string intf;
- close_box()
- | Custom_runtime ->
- print_string "Error while building custom runtime system"
-
diff --git a/bytecomp/linker.mli b/bytecomp/linker.mli
deleted file mode 100644
index b4c57e632c..0000000000
--- a/bytecomp/linker.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(* Link .cmo files and produce a bytecode executable. *)
-
-val link: string list -> unit
-
-val check_consistency: string -> Emitcode.compilation_unit -> unit
-
-type error =
- File_not_found of string
- | Not_an_object_file of string
- | Symbol_error of string * Symtable.error
- | Inconsistent_import of string * string * string
- | Custom_runtime
-
-exception Error of error
-
-val report_error: error -> unit
diff --git a/byterun/oldlexing.c b/byterun/oldlexing.c
deleted file mode 100644
index fa275eb991..0000000000
--- a/byterun/oldlexing.c
+++ /dev/null
@@ -1,90 +0,0 @@
-/***********************************************************************/
-/* */
-/* Caml Special Light */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1995 Institut National de Recherche en Informatique et */
-/* Automatique. Distributed only by permission. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* The table-driven automaton for lexers generated by camllex. */
-
-#include "mlvalues.h"
-#include "stacks.h"
-#include "str.h"
-
-struct lexer_buffer {
- value refill_buff;
- value lex_buffer;
- value lex_buffer_len;
- value lex_abs_pos;
- value lex_start_pos;
- value lex_curr_pos;
- value lex_last_pos;
-};
-
-struct lexing_table {
- value lex_base;
- value lex_backtrk;
- value lex_default;
- value lex_trans;
- value lex_check;
-};
-
-#ifdef BIG_ENDIAN
-#define Short(tbl,n) \
- (*((unsigned char *)((tbl) + (n) * sizeof(short))) + \
- (*((schar *)((tbl) + (n) * sizeof(short) + 1)) << 8))
-#else
-#define Short(tbl,n) (((short *)(tbl))[n])
-#endif
-
-value lex_engine(tbl, start_state, lexbuf) /* ML */
- struct lexing_table * tbl;
- value start_state;
- struct lexer_buffer * lexbuf;
-{
- int state, last_action, base, backtrk, c;
-
- state = Int_val(start_state);
- lexbuf->lex_last_pos = lexbuf->lex_start_pos = lexbuf->lex_curr_pos;
- last_action = -1;
- while(1) {
- /* Lookup base address or action number for current state */
- base = Short(tbl->lex_base, state);
- if (base < 0) return Val_int(-base-1);
- /* See if it's a backtrack point */
- backtrk = Short(tbl->lex_backtrk, state);
- if (backtrk >= 0) {
- lexbuf->lex_last_pos = lexbuf->lex_curr_pos;
- last_action = backtrk;
- }
- /* Read next input char */
- if (lexbuf->lex_curr_pos >= lexbuf->lex_buffer_len) {
- Push_roots (r, 2);
- r[0] = (value) tbl;
- r[1] = (value) lexbuf;
- callback(lexbuf->refill_buff, (value) lexbuf);
- tbl = (struct lexing_table *) r[0];
- lexbuf = (struct lexer_buffer *) r[1];
- Pop_roots ();
- }
- c = Byte_u(lexbuf->lex_buffer, Long_val(lexbuf->lex_curr_pos));
- lexbuf->lex_curr_pos += 2;
- /* Determine next state */
- if (Short(tbl->lex_check, base + c) == state)
- state = Short(tbl->lex_trans, base + c);
- else
- state = Short(tbl->lex_default, state);
- /* If no transition on this char, return to last backtrack point */
- if (state < 0) {
- lexbuf->lex_curr_pos = lexbuf->lex_last_pos;
- return Val_int(last_action);
- }
- }
-}
-
diff --git a/stdlib/baltree.ml b/stdlib/baltree.ml
deleted file mode 100644
index 6ecf9cf626..0000000000
--- a/stdlib/baltree.ml
+++ /dev/null
@@ -1,193 +0,0 @@
-(* Weight-balanced binary trees.
- These are binary trees such that one child of a node has at most N times
- as many elements as the other child. We take N=3. *)
-
-type 'a t = Empty | Node of 'a t * 'a * 'a t * int
- (* The type of trees containing elements of type ['a].
- [Empty] is the empty tree (containing no elements). *)
-
-type 'a contents = Nothing | Something of 'a
- (* Used with the functions [modify] and [List.split], to represent
- the presence or the absence of an element in a tree. *)
-
-(* Compute the size (number of nodes and leaves) of a tree. *)
-
-let size = function
- Empty -> 1
- | Node(_, _, _, s) -> s
-
-(* Creates a new node with left son l, value x and right son r.
- l and r must be balanced and size l / size r must be between 1/N and N.
- Inline expansion of size for better speed. *)
-
-let new l x r =
- let sl = match l with Empty -> 0 | Node(_,_,_,s) -> s in
- let sr = match r with Empty -> 0 | Node(_,_,_,s) -> s in
- Node(l, x, r, sl + sr + 1)
-
-(* Same as new, but performs rebalancing if necessary.
- Assumes l and r balanced, and size l / size r "reasonable"
- (between 1/N^2 and N^2 ???).
- Inline expansion of new for better speed in the most frequent case
- where no rebalancing is required. *)
-
-let bal l x r =
- let sl = match l with Empty -> 0 | Node(_,_,_,s) -> s in
- let sr = match r with Empty -> 0 | Node(_,_,_,s) -> s in
- if sl > 3 * sr then begin
- match l with
- Empty -> invalid_arg "Baltree.bal"
- | Node(ll, lv, lr, _) ->
- if size ll >= size lr then
- new ll lv (new lr x r)
- else begin
- match lr with
- Empty -> invalid_arg "Baltree.bal"
- | Node(lrl, lrv, lrr, _)->
- new (new ll lv lrl) lrv (new lrr x r)
- end
- end else if sr > 3 * sl then begin
- match r with
- Empty -> invalid_arg "Baltree.bal"
- | Node(rl, rv, rr, _) ->
- if size rr >= size rl then
- new (new l x rl) rv rr
- else begin
- match rl with
- Empty -> invalid_arg "Baltree.bal"
- | Node(rll, rlv, rlr, _) ->
- new (new l x rll) rlv (new rlr rv rr)
- end
- end else
- Node(l, x, r, sl + sr + 1)
-
-(* Same as bal, but rebalance regardless of the original ratio
- size l / size r *)
-
-let rec join l x r =
- match bal l x r with
- Empty -> invalid_arg "Baltree.join"
- | Node(l', x', r', _) as t' ->
- let sl = size l' and sr = size r' in
- if sl > 3 * sr or sr > 3 * sl then join l' x' r' else t'
-
-(* Merge two trees l and r into one.
- All elements of l must precede the elements of r.
- Assumes size l / size r between 1/N and N. *)
-
-let rec merge t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
- bal l1 v1 (bal (merge r1 l2) v2 r2)
-
-(* Same as merge, but does not assume anything about l and r. *)
-
-let rec concat t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
- join l1 v1 (join (concat r1 l2) v2 r2)
-
-(* Insertion *)
-
-let add searchpred x t =
- let rec add = function
- Empty ->
- Node(Empty, x, Empty, 1)
- | Node(l, v, r, _) as t ->
- let c = searchpred v in
- if c == 0 then t else
- if c < 0 then bal (add l) v r else bal l v (add r)
- in add t
-
-(* Membership *)
-
-let contains searchpred t =
- let rec contains = function
- Empty -> false
- | Node(l, v, r, _) ->
- let c = searchpred v in
- if c == 0 then true else
- if c < 0 then contains l else contains r
- in contains t
-
-(* Search *)
-
-let find searchpred t =
- let rec find = function
- Empty ->
- raise Not_found
- | Node(l, v, r, _) ->
- let c = searchpred v in
- if c == 0 then v else
- if c < 0 then find l else find r
- in find t
-
-(* Deletion *)
-
-let remove searchpred t =
- let rec remove = function
- Empty ->
- Empty
- | Node(l, v, r, _) ->
- let c = searchpred v in
- if c == 0 then merge l r else
- if c < 0 then bal (remove l) v r else bal l v (remove r)
- in remove t
-
-(* Modification *)
-
-let modify searchpred modifier t =
- let rec modify = function
- Empty ->
- begin match modifier Nothing with
- Nothing -> Empty
- | Something v -> Node(Empty, v, Empty, 1)
- end
- | Node(l, v, r, s) ->
- let c = searchpred v in
- if c == 0 then
- begin match modifier(Something v) with
- Nothing -> merge l r
- | Something v' -> Node(l, v', r, s)
- end
- else if c < 0 then bal (modify l) v r else bal l v (modify r)
- in modify t
-
-(* Splitting *)
-
-let split searchpred =
- let rec split = function
- Empty ->
- (Empty, Nothing, Empty)
- | Node(l, v, r, _) ->
- let c = searchpred v in
- if c == 0 then (l, Something v, r)
- else if c < 0 then
- let (ll, vl, rl) = split l in (ll, vl, join rl v r)
- else
- let (lr, vr, rr) = split r in (join l v lr, vr, rr)
- in split
-
-(* Comparison (by lexicographic ordering of the fringes of the two trees). *)
-
-let compare cmp s1 s2 =
- let rec compare_aux l1 l2 =
- match (l1, l2) with
- ([], []) -> 0
- | ([], _) -> -1
- | (_, []) -> 1
- | (Empty::t1, Empty::t2) ->
- compare_aux t1 t2
- | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
- let c = cmp v1 v2 in
- if c != 0 then c else compare_aux (r1::t1) (r2::t2)
- | (Node(l1, v1, r1, _) :: t1, t2) ->
- compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
- | (t1, Node(l2, v2, r2, _) :: t2) ->
- compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
- in
- compare_aux [s1] [s2]
diff --git a/stdlib/baltree.mli b/stdlib/baltree.mli
deleted file mode 100644
index 4e6f35efbb..0000000000
--- a/stdlib/baltree.mli
+++ /dev/null
@@ -1,77 +0,0 @@
-(* Basic balanced binary trees *)
-
-(* This module implements balanced ordered binary trees.
- All operations over binary trees are applicative (no side-effects).
- The [set] and [List.map] modules are based on this module.
- This modules gives a more direct access to the internals of the
- binary tree implementation than the [set] and [List.map] abstractions,
- but is more delicate to use and not as safe. For advanced users only. *)
-
-type 'a t = Empty | Node of 'a t * 'a * 'a t * int
- (* The type of trees containing elements of type ['a].
- [Empty] is the empty tree (containing no elements). *)
-
-type 'a contents = Nothing | Something of 'a
- (* Used with the functions [modify] and [List.split], to represent
- the presence or the absence of an element in a tree. *)
-
-val add: ('a -> int) -> 'a -> 'a t -> 'a t
- (* [add f x t] inserts the element [x] into the tree [t].
- [f] is an ordering function: [f y] must return [0] if
- [x] and [y] are equal (or equivalent), a negative integer if
- [x] is smaller than [y], and a positive integer if [x] is
- greater than [y]. The tree [t] is returned unchanged if
- it already contains an element equivalent to [x] (that is,
- an element [y] such that [f y] is [0]).
- The ordering [f] must be consistent with the orderings used
- to build [t] with [add], [remove], [modify] or [List.split]
- operations. *)
-val contains: ('a -> int) -> 'a t -> bool
- (* [contains f t] checks whether [t] contains an element
- satisfying [f], that is, an element [x] such
- that [f x] is [0]. [f] is an ordering function with the same
- constraints as for [add]. It can be coarser (identify more
- elements) than the orderings used to build [t], but must be
- consistent with them. *)
-val find: ('a -> int) -> 'a t -> 'a
- (* Same as [contains], except that [find f t] returns the element [x]
- such that [f x] is [0], or raises [Not_found] if none has been
- found. *)
-val remove: ('a -> int) -> 'a t -> 'a t
- (* [remove f t] removes one element [x] of [t] such that [f x] is [0].
- [f] is an ordering function with the same constraints as for [add].
- [t] is returned unchanged if it does not contain any element
- satisfying [f]. If several elements of [t] satisfy [f],
- only one is removed. *)
-val modify: ('a -> int) -> ('a contents -> 'a contents) -> 'a t -> 'a t
- (* General insertion/modification/deletion function.
- [modify f g t] searchs [t] for an element [x] satisfying the
- ordering function [f]. If one is found, [g] is applied to
- [Something x]; if [g] returns [Nothing], the element [x]
- is removed; if [g] returns [Something y], the element [y]
- replaces [x] in the tree. (It is assumed that [x] and [y]
- are equivalent, in particular, that [f y] is [0].)
- If the tree does not contain any [x] satisfying [f],
- [g] is applied to [Nothing]; if it returns [Nothing],
- the tree is returned unchanged; if it returns [Something x],
- the element [x] is inserted in the tree. (It is assumed that
- [f x] is [0].) The functions [add] and [remove] are special cases
- of [modify], slightly more efficient. *)
-val split: ('a -> int) -> 'a t -> 'a t * 'a contents * 'a t
- (* [split f t] returns a triple [(less, elt, greater)] where
- [less] is a tree containing all elements [x] of [t] such that
- [f x] is negative, [greater] is a tree containing all
- elements [x] of [t] such that [f x] is positive, and [elt]
- is [Something x] if [t] contains an element [x] such that
- [f x] is [0], and [Nothing] otherwise. *)
-val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
- (* Compare two trees. The first argument [f] is a comparison function
- over the tree elements: [f e1 e2] is zero if the elements [e1] and
- [e2] are equal, negative if [e1] is smaller than [e2],
- and positive if [e1] is greater than [e2]. [compare f t1 t2]
- compares the fringes of [t1] and [t2] by lexicographic extension
- of [f]. *)
-(*--*)
-val join: 'a t -> 'a -> 'a t -> 'a t
-val concat: 'a t -> 'a t -> 'a t
-
diff --git a/test/Results/runtest b/test/Results/runtest
deleted file mode 100644
index 08ccb468ff..0000000000
--- a/test/Results/runtest
+++ /dev/null
@@ -1 +0,0 @@
-$camlrun $1 | cmp - Results/$1.out
diff --git a/tools/convert b/tools/convert
deleted file mode 100755
index bc43990205..0000000000
--- a/tools/convert
+++ /dev/null
@@ -1,233 +0,0 @@
-#!/usr/local/bin/perl
-
-# Conversion of a Caml Light 0.7 file to Caml Special Light.
-
-# The conversion table
-
-$convtbl=
-"value val
-int_of_float truncate
-float_of_int float
-vect array
-fast_really_input unsafe_really_input
-io__exit exit
-vect_length Array.length
-make_vect Array.create
-make_matrix Array.create_matrix
-concat_vect Array.concat
-sub_vect Array.sub
-copy_vect Array.copy
-fill_vect Array.fill
-blit_vect Array.blit
-do_vect Array.iter
-map_vect Array.map
-vect_of_list Array.of_list
-list_of_vect Array.to_list
-int_of_char Char.code
-char_of_int Char.chr
-char_for_read Char.escaped
-fchar__char_of_int Char.unsafe_chr
-hashtbl__do_table Hashtbl.iter
-do_table Hashtbl.iter
-lexing__create_lexer_channel Lexing.from_channel
-lexing__create_lexer_string Lexing.from_string
-lexing__create_lexer Lexing.from_function
-lexing__get_lexeme Lexing.lexeme
-lexing__get_lexeme_char Lexing.lexeme_char
-lexing__get_lexeme_start Lexing.lexeme_start
-lexing__get_lexeme_end Lexing.lexeme_end
-create_lexer_channel Lexing.from_channel
-create_lexer_string Lexing.from_string
-create_lexer Lexing.from_function
-get_lexeme Lexing.lexeme
-get_lexeme_char Lexing.lexeme_char
-get_lexeme_start Lexing.lexeme_start
-get_lexeme_end Lexing.lexeme_end
-list_length List.length
-rev List.rev
-flatten List.flatten
-do_list List.iter
-map List.map
-it_list List.fold_left
-list_it List.fold_right
-do_list2 List.iter2
-map2 List.map2
-iter2 List.iter2
-it_list2 List.fold_left2
-list_it2 List.fold_right2
-for_all List.for_all
-exists List.exists
-mem List.mem
-assoc List.assoc
-mem_assoc List.mem_assoc
-assq List.assq
-split List.split
-combine List.combine
-obj__obj Obj.t
-obj__repr Obj.repr
-obj__magic_obj Obj.magic
-obj__magic Obj.magic
-obj__is_block Obj.is_block
-obj__obj_tag Obj.tag
-obj__obj_size Obj.size
-obj__obj_field Obj.field
-obj__set_obj_field Obj.set_field
-obj__obj_block Obj.new_block
-obj__update Obj.update
-magic_obj Obj.magic
-magic Obj.magic
-is_block Obj.is_block
-obj_tag Obj.tag
-obj_size Obj.size
-obj_field Obj.field
-set_obj_field Obj.set_field
-obj_block Obj.new_block
-printexc__f Printexc.catch
-sort__sort Sort.list
-sort Sort.list
-string_length String.length
-nth_char String.get
-set_nth_char String.set
-sub_string String.sub
-create_string String.create
-make_string String.make
-fill_string String.fill
-blit_string String.blit
-string_for_read String.escaped
-fstring__nth_char String.unsafe_get
-fstring__set_nth_char String.unsafe_set
-fstring__blit_string String.unsafe_blit
-sys__Sys_error Sys_error
-sys__exit exit
-sys__command_line Sys.argv
-sys__O_RDONLY Sys.Open_rdonly
-sys__O_WRONLY Sys.Open_wronly
-sys__O_RDWR Sys.Open_rdwr
-sys__O_APPEND Sys.Open_append
-sys__O_CREAT Sys.Open_creat
-sys__O_TRUNC Sys.Open_trunc
-sys__O_EXCL Sys.Open_excl
-sys__O_BINARY Sys.Open_binary
-sys__O_TEXT Sys.Open_text
-sys__open Sys.open_desc
-sys__close Sys.close_desc
-sys__system_command Sys.command
-system_command Sys.command
-command_line Sys.argv
-O_RDONLY Sys.Open_rdonly
-O_WRONLY Sys.Open_wronly
-O_RDWR Sys.Open_rdwr
-O_APPEND Sys.Open_append
-O_CREAT Sys.Open_creat
-O_TRUNC Sys.Open_trunc
-O_EXCL Sys.Open_excl
-O_BINARY Sys.Open_binary
-O_TEXT Sys.Open_text";
-
-# Initialize the table %conv
-%conv = split(/\s+/, $convtbl);
-
-# Parse options
-$_ = $ARGV[0];
-$keep_semisemi = 1, shift if /^-semi/;
-
-# Open input.
-$infile = $ARGV[0];
-open(IN, $infile) || die("Cannot open $infile");
-$interface = ($infile =~ /\.mli$/);
-
-# If it's a .ml or .mll file: we must insert definitions from the .mli
-# before the first definition
-
-if ($infile =~ /^(.*)\.(ml|mll)$/ && open(INTERFACE, "$1.mli")) {
-
-# Copy and translate the header of the file (first comment and #open decls)
-# Stop at first definition
- $_ = <IN>;
- if (/^\(\*/) {
- do convert();
- while (! /\*\)/) { $_ = <IN>; do convert(); }
- $_ = <IN>;
- }
- while(/^$/ || /^#open / || /^{$/) {
- do convert();
- $_ = <IN>;
- }
- $saved = $_;
- $copy = 0;
-
-# Copy and translate manifest definitions from the .mli
- while(<INTERFACE>) {
- $copy = 1 if /^type .*=/ || /^#open/ || /^exception/;
- $copy = 0 if /^type [^=]*$/ || /^value /;
- do convert() if $copy;
- }
- close(INTERFACE);
- $_ = $saved;
-
-# Finish translation of main file
- do convert();
- while(<IN>) {
- do convert();
- }
-
-} else {
-
-# For other kinds of files (.mli, .mly), just copy as is
- while(<IN>) {
- do convert();
- }
-}
-
-close(IN);
-
-# Convert and print one line (in $_)
-sub convert {
- chop;
-# Double-semicolon
- if (! $keep_semisemi) {
- return if /^;;\s*$/;
- s/;;//;
- }
-# Identifiers that have been renamed
- s/([A-Za-z][A-Za-z0-9'_]*(__[A-Za-z][A-Za-z0-9'_]*)?)/$conv{$1} || $1/eg;
-# 'type glop == tau'
- s/((type|and)\s+(\(.*\)\s+|'[a-z]\s+)?[A-Za-z][A-Za-z0-9'_]*\s+)==/\1=/;
-# 'and' for values in .mli files -- what a terrible hack!
- if ($interface) { s/^ and\b/val/; }
-# Open
- if (s/#\s*open\s*"([^"]*)"/"open " . do capitalize($1)/e) {
- /open ([A-Za-z0-9_']+)/;
- return if $opened{$1};
- $opened{$1} = 1;
- }
-# Module references
- s/([A-Za-z][A-Za-z0-9_']*)__/do capitalize($1) . "."/eg;
-# Character literals
- s/`([^\\]|\\[\\`ntbr]|\\[0-9][0-9][0-9])`/do convert_char($1)/eg;
-# Over!
- print $_, "\n";
-}
-
-close(IN);
-close(OUT);
-
-# Capitalize a string
-sub capitalize {
- local ($_) = @_;
- m/^(.)(.*)/;
- $hd = $1;
- $tl = $2;
- $hd =~ tr/a-z/A-Z/;
- return $hd . $tl;
-}
-
-# Convert a character literal
-sub convert_char {
- local ($_) = @_;
- s/\\`/`/;
- s/'/\\'/;
- s/^/'/;
- s/$/'/;
- return $_;
-}
diff --git a/utils/cset.ml b/utils/cset.ml
deleted file mode 100644
index f2c8482b55..0000000000
--- a/utils/cset.ml
+++ /dev/null
@@ -1,103 +0,0 @@
-(* Sets over ordered types *)
-
-type 'a t = Empty | Node of 'a t * 'a * 'a t * int
-
-let empty = Empty
-
-(* Compute the size (number of nodes and leaves) of a tree. *)
-
-let size = function
- Empty -> 1
- | Node(_, _, _, s) -> s
-
-(* Creates a new node with left son l, value x and right son r.
- l and r must be balanced and size l / size r must be between 1/N and N.
- Inline expansion of size for better speed. *)
-
-let new l x r =
- let sl = match l with Empty -> 0 | Node(_,_,_,s) -> s in
- let sr = match r with Empty -> 0 | Node(_,_,_,s) -> s in
- Node(l, x, r, sl + sr + 1)
-
-(* Same as new, but performs rebalancing if necessary.
- Assumes l and r balanced, and size l / size r "reasonable".
- Inline expansion of new for better speed in the most frequent case
- where no rebalancing is required. *)
-
-let bal l x r =
- let sl = match l with Empty -> 0 | Node(_,_,_,s) -> s in
- let sr = match r with Empty -> 0 | Node(_,_,_,s) -> s in
- if sl > 3 * sr then begin
- match l with
- Empty -> invalid_arg "Cset.bal"
- | Node(ll, lv, lr, _) ->
- if size ll >= size lr then
- new ll lv (new lr x r)
- else begin
- match lr with
- Empty -> invalid_arg "Cset.bal"
- | Node(lrl, lrv, lrr, _)->
- new (new ll lv lrl) lrv (new lrr x r)
- end
- end else if sr > 3 * sl then begin
- match r with
- Empty -> invalid_arg "Cset.bal"
- | Node(rl, rv, rr, _) ->
- if size rr >= size rl then
- new (new l x rl) rv rr
- else begin
- match rl with
- Empty -> invalid_arg "Cset.bal"
- | Node(rll, rlv, rlr, _) ->
- new (new l x rll) rlv (new rlr rv rr)
- end
- end else
- Node(l, x, r, sl + sr + 1)
-
-(* Merge two trees l and r into one.
- All elements of l must precede the elements of r.
- Assumes size l / size r between 1/N and N. *)
-
-let rec merge l r =
- match (l, r) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
- bal l1 v1 (bal (merge r1 l2) v2 r2)
-
-(* Insertion *)
-
-let rec add x = function
- Empty ->
- Node(Empty, x, Empty, 1)
- | Node(l, v, r, _) as t ->
- let c = compare x v in
- if c = 0 then t else
- if c < 0 then bal (add x l) v r else bal l v (add x r)
-
-(* Membership *)
-
-let rec mem x = function
- Empty ->
- false
- | Node(l, v, r, _) ->
- let c = compare x v in
- c = 0 or mem x (if c < 0 then l else r)
-
-(* Removal *)
-
-let rec remove x = function
- Empty ->
- Empty
- | Node(l, v, r, _) ->
- let c = compare x v in
- if c = 0 then merge l r else
- if c < 0 then bal (remove x l) v r else bal l v (remove x r)
-
-(* Contents *)
-
-let elements s =
- let rec elements accu = function
- Empty -> accu
- | Node(l, v, r, _) -> elements (v :: elements accu r) l
- in elements [] s
diff --git a/utils/cset.mli b/utils/cset.mli
deleted file mode 100644
index a7f4cae9c7..0000000000
--- a/utils/cset.mli
+++ /dev/null
@@ -1,9 +0,0 @@
-(* Sets over types ordered with the default ordering *)
-
-type 'a t
-
-val empty: 'a t
-val mem: 'a -> 'a t -> bool
-val add: 'a -> 'a t -> 'a t
-val remove: 'a -> 'a t -> 'a t
-val elements: 'a t -> 'a list
diff --git a/utils/meta.ml b/utils/meta.ml
deleted file mode 100644
index 08077cf993..0000000000
--- a/utils/meta.ml
+++ /dev/null
@@ -1,7 +0,0 @@
-external global_data : unit -> Obj.t array = "get_global_data"
-external realloc_global_data : int -> unit = "realloc_global"
-external static_alloc : int -> string = "static_alloc"
-external static_free : string -> unit = "static_free"
-external static_resize : string -> int -> string = "static_resize"
-external execute_bytecode : string -> int -> Obj.t = "execute_bytecode"
-external available_primitives : unit -> string array = "available_primitives"
diff --git a/utils/meta.mli b/utils/meta.mli
deleted file mode 100644
index 9987ba7e86..0000000000
--- a/utils/meta.mli
+++ /dev/null
@@ -1,9 +0,0 @@
-(* To control the runtime system and bytecode interpreter *)
-
-external global_data : unit -> Obj.t array = "get_global_data"
-external realloc_global_data : int -> unit = "realloc_global"
-external static_alloc : int -> string = "static_alloc"
-external static_free : string -> unit = "static_free"
-external static_resize : string -> int -> string = "static_resize"
-external execute_bytecode : string -> int -> Obj.t = "execute_bytecode"
-external available_primitives : unit -> string array = "available_primitives"
View Lorry Controller Status