diff --git a/asmcomp/Makefile b/asmcomp/Makefile deleted file mode 100644 index dc70e9131..000000000 --- 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 f9fe6afad..000000000 --- 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 f912a8d21..000000000 --- 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 d41d2b71c..000000000 --- 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 c7920803a..000000000 --- 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 b8bcbf4f3..000000000 --- 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 e50c0edc6..000000000 --- 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 2b10ccf4a..000000000 --- a/asmrun/compare.c +++ /dev/null @@ -1,65 +0,0 @@ -#include -#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 ef22b0893..000000000 --- a/asmrun/debug.c +++ /dev/null @@ -1,135 +0,0 @@ -#include -#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 285c239a1..000000000 --- a/asmrun/gc.c +++ /dev/null @@ -1,295 +0,0 @@ -#include -#include -#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 50369be9c..000000000 --- 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 edead293c..000000000 --- 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 b05a134ac..000000000 --- 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 b8061b46c..000000000 --- a/asmrun/runtime.c +++ /dev/null @@ -1,51 +0,0 @@ -/* A very simplified runtime system for the native code compiler */ - -#include -#include -#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; -} -