dead files
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2654 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Jacques Garrigue
parent
1b3923e514
commit
71d0a1a181
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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 "."
|
||||
|
|
@ -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
|
||||
|
|
@ -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 }
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
(* "Sequentialization": from C-- to sequences of pseudo-instructions
|
||||
with pseudo-registers. *)
|
||||
|
||||
val fundecl: Cmm.fundecl -> Mach.fundecl
|
||||
|
|
@ -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)
|
||||
|
||||
135
asmrun/debug.c
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);
|
||||
}
|
||||
}
|
||||
295
asmrun/gc.c
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;
|
||||
}
|
||||
172
asmrun/i386.asm
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
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#ifdef DEBUG
|
||||
#define Assert(x) if(!(x)) failed_assert(__FILE__, __LINE__)
|
||||
#else
|
||||
#define Assert(x)
|
||||
#endif
|
||||
|
|
@ -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
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue