Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

This commit was manufactured by cvs2svn to create tag 'ocaml204'.

git-svn-id: http://caml.inria.fr/svn/ocaml/release/2.04@2612 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
commit e3a7aef180806f08aa03e4d49f604c8fa776ba27 1 parent d15ee5c
(no author) authored
View
91 asmcomp/Makefile
@@ -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
View
10 asmcomp/lexcmm.mli
@@ -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
View
17 asmcomp/main.ml
@@ -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
-
View
26 asmcomp/parsecmmaux.ml
@@ -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 "."
View
12 asmcomp/parsecmmaux.mli
@@ -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
View
354 asmcomp/sequence.ml
@@ -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 }
View
4 asmcomp/sequence.mli
@@ -1,4 +0,0 @@
-(* "Sequentialization": from C-- to sequences of pseudo-instructions
- with pseudo-registers. *)
-
-val fundecl: Cmm.fundecl -> Mach.fundecl
View
65 asmrun/compare.c
@@ -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)
-
View
135 asmrun/debug.c
@@ -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);
- }
-}
View
295 asmrun/gc.c
@@ -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;
-}
View
172 asmrun/i386.asm
@@ -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
View
5 asmrun/misc.h
@@ -1,5 +0,0 @@
-#ifdef DEBUG
-#define Assert(x) if(!(x)) failed_assert(__FILE__, __LINE__)
-#else
-#define Assert(x)
-#endif
View
36 asmrun/mlvalues.h
@@ -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
View
51 asmrun/runtime.c
@@ -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;
-}
-
View
444 bytecomp/codegen.ml
@@ -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)
-
View
8 bytecomp/codegen.mli
@@ -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
-
View
62 bytecomp/librarian.ml
@@ -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"
-
View
18 bytecomp/librarian.mli
@@ -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
View
262 bytecomp/linker.ml
@@ -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"
-
View
16 bytecomp/linker.mli
@@ -1,16 +0,0 @@
-(* Link .cmo files and produce a bytecode executable. *)
-
-val link: string list -> unit
-
-val check_consistency: string -> Emitcode.compilation_unit -> unit
-
-type error =
- File_not_found of string
- | Not_an_object_file of string
- | Symbol_error of string * Symtable.error
- | Inconsistent_import of string * string * string
- | Custom_runtime
-
-exception Error of error
-
-val report_error: error -> unit
View
90 byterun/oldlexing.c
@@ -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);
- }
- }
-}
-
View
193 stdlib/baltree.ml
@@ -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,