diff options
57 files changed, 1123 insertions, 389 deletions
@@ -78,7 +78,7 @@ all: runtime camlc camllex camlyacc library camltop # Never mind, just do make bootstrap to reach fixpoint again. # Compile everything the first time -world: coldstart all +world: coldstart clean all # Complete bootstrapping cycle bootstrap: diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index d80ecf3c8..e5fdf5b3d 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -172,7 +172,7 @@ let link objfiles = raise(Error(Assembler_error startup)); try call_linker (List.map object_file_name objfiles) startup_obj; - remove_file startup; + if not !Clflags.keep_startup_file then remove_file startup; remove_file startup_obj with x -> remove_file startup_obj; diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index cfeab7b39..524ddf99a 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -49,7 +49,7 @@ type memory_chunk = type operation = Capply of machtype - | Cextcall of string * machtype + | Cextcall of string * machtype * bool | Cproj of int * int | Cload of machtype | Cloadchunk of memory_chunk diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 2315f8a41..1c8290b3f 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -35,7 +35,7 @@ type memory_chunk = type operation = Capply of machtype - | Cextcall of string * machtype + | Cextcall of string * machtype * bool | Cproj of int * int | Cload of machtype | Cloadchunk of memory_chunk diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 07ff5d3b4..2e885183c 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -7,29 +7,35 @@ open Lambda open Clambda open Cmm +(* Local binding of complex expressions *) + +let bind name arg fn = + match arg with + Cvar _ | Cconst_int _ | Cconst_symbol _ | Cconst_pointer _ -> fn arg + | _ -> let id = Ident.new name in Clet(id, arg, fn (Cvar id)) + (* Block headers. Meaning of the tag field: - 0xFF: infix header - 0xFE: finalized - 0xFD: abstract - 0xFC: string - 0xFB: float - 0xFA: closure - 0 - 0xF9: regular blocks *) - -let block_header tag sz = (sz lsl 11) + tag -let closure_header sz = block_header 0xFA sz -let infix_header ofs = block_header 0xFF ofs -let float_header = block_header 0xFB (size_float / size_addr) -let string_header len = block_header 0xFC ((len + size_addr) / size_addr) - -let modified = 1 lsl 10 -let alloc_block_header tag sz = Cconst_int((block_header tag sz) lor modified) -let alloc_closure_header sz = Cconst_int((closure_header sz) lor modified) + 0 - 249: regular blocks + 250: closures + 251: infix closure + 252: abstract + 253: string + 254: float + 255: finalized *) + +let block_header tag sz = (sz lsl 10) + tag +let closure_header sz = block_header 250 sz +let infix_header ofs = block_header 251 ofs +let float_header = block_header 254 (size_float / size_addr) +let string_header len = block_header 253 ((len + size_addr) / size_addr) + +let alloc_block_header tag sz = Cconst_int(block_header tag sz) +let alloc_closure_header sz = Cconst_int(closure_header sz) let alloc_infix_header ofs = Cconst_int(infix_header ofs) (* Integers *) -let int_const n = Cconst_int((n lsl 1 + 1)) +let int_const n = Cconst_int((n lsl 1) + 1) let add_const c n = if n = 0 then c else Cop(Caddi, [c; Cconst_int n]) @@ -98,7 +104,8 @@ let unbox_float = function let return_unit c = Csequence(c, Cconst_int 1) let rec remove_unit = function - Csequence(c, Cconst_int 1) -> c + Cconst_int 1 -> Ctuple [] + | Csequence(c, Cconst_int 1) -> c | Csequence(c1, c2) -> Csequence(c1, remove_unit c2) | Cifthenelse(cond, ifso, ifnot) -> @@ -131,21 +138,6 @@ let get_tag ptr = Cop(Cloadchunk Byte_unsigned, [Cop(Cadda, [ptr; Cconst_int(tag_offset)])]) -(* Determine if a clambda is guaranteed to return an integer or a pointer - outside the heap, making it unneccesary to do Cmodify. *) - -let rec is_outside_heap = function - Uconst _ -> true - | Uprim(p, _) -> - begin match p with - Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint - | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint - | Pintcomp _ | Poffsetint _ | Pfloatcomp _ - | Pgetstringchar | Pvectlength -> true - | _ -> false - end - | _ -> false - (* Array indexing *) let log2_size_addr = Misc.log2 size_addr @@ -166,6 +158,22 @@ let array_indexing ptr ofs = Cop(Cadda, [ptr; add_const (lsl_const ofs (log2_size_addr - 1)) ((-1) lsl (log2_size_addr - 1))]) +(* String length *) + +let string_length exp = + bind "str" exp (fun str -> + let tmp_var = Ident.new "tmp" in + Clet(tmp_var, + Cop(Csubi, + [Cop(Clsl, + [Cop(Clsr, [get_field str (-1); Cconst_int 10]); + Cconst_int log2_size_addr]); + Cconst_int 1]), + Cop(Csubi, + [Cvar tmp_var; + Cop(Cloadchunk Byte_unsigned, + [Cop(Cadda, [str; Cvar tmp_var])])]))) + (* To compile "let rec" over values *) let fundecls_size fundecls = @@ -242,13 +250,6 @@ let transl_constant = function structured_constants := (lbl, cst) :: !structured_constants; Cconst_symbol lbl -(* Local binding of complex expressions *) - -let bind name arg fn = - match arg with - Cvar id -> fn id - | _ -> let id = Ident.new name in Clet(id, arg, fn id) - (* Translate an expression *) let functions = (Queue.new() : (string * Ident.t list * ulambda) Queue.t) @@ -287,9 +288,8 @@ let rec transl = function | Udirect_apply(lbl, args) -> Cop(Capply typ_addr, Cconst_symbol lbl :: List.map transl args) | Ugeneric_apply(clos, [arg]) -> - bind "fun" (transl clos) (fun clos_var -> - Cop(Capply typ_addr, - [get_field (Cvar clos_var) 0; transl arg; Cvar clos_var])) + bind "fun" (transl clos) (fun clos -> + Cop(Capply typ_addr, [get_field clos 0; transl arg; clos])) | Ugeneric_apply(clos, args) -> let arity = List.length args in Cop(Capply typ_addr, @@ -321,17 +321,14 @@ let rec transl = function List.map transl args) | Uprim(Pfield n, [arg]) -> get_field (transl arg) n - | Uprim(Psetfield n, [loc; newval]) -> - let c = - if is_outside_heap newval then - set_field (transl loc) n (transl newval) - else - bind "modify" (transl loc) (fun loc_var -> - Csequence(Cop(Cmodify, [Cvar loc_var]), - set_field (transl loc) n (transl newval))) - in return_unit c - | Uprim(Pccall(lbl, arity), args) -> - Cop(Cextcall(lbl, typ_addr), List.map transl args) + | Uprim(Psetfield(n, ptr), [loc; newval]) -> + if ptr then + return_unit(Cop(Cextcall("modify", typ_void, false), + [field_address (transl loc) n; transl newval])) + else + return_unit(set_field (transl loc) n (transl newval)) + | Uprim(Pccall(lbl, arity, alloc), args) -> + Cop(Cextcall(lbl, typ_addr, alloc), List.map transl args) | Uprim(Praise, [arg]) -> Cop(Craise, [transl arg]) | Uprim(Psequand, [arg1; arg2]) -> @@ -370,10 +367,9 @@ let rec transl = function add_const (transl arg) (n lsl 1) | Uprim(Poffsetref n, [arg]) -> return_unit - (bind "ref" (transl arg) (fun arg_var -> + (bind "ref" (transl arg) (fun arg -> Cop(Cstore, - [Cvar arg_var; - add_const (Cop(Cload typ_int, [Cvar arg_var])) (n lsl 1)]))) + [arg; add_const (Cop(Cload typ_int, [arg])) (n lsl 1)]))) | Uprim(Pnegfloat, [arg]) -> box_float(Cop(Caddf, [Cconst_float "0.0"; transl_unbox_float arg])) @@ -386,9 +382,10 @@ let rec transl = function | Uprim(Pdivfloat, [arg1; arg2]) -> box_float(Cop(Cdivf, [transl_unbox_float arg1; transl_unbox_float arg2])) | Uprim(Pfloatcomp cmp, [arg1; arg2]) -> - Cifthenelse(Cop(Ccmpf(transl_comparison cmp), - [transl_unbox_float arg1; transl_unbox_float arg2]), - int_const 1, int_const 0) + tag_int(Cop(Ccmpf(transl_comparison cmp), + [transl_unbox_float arg1; transl_unbox_float arg2])) + | Uprim(Pstringlength, [arg]) -> + tag_int(string_length (transl arg)) | Uprim(Pgetstringchar, [arg1; arg2]) -> tag_int(Cop(Cloadchunk Byte_unsigned, [add_int (transl arg1) (untag_int(transl arg2))])) @@ -396,36 +393,66 @@ let rec transl = function return_unit(Cop(Cstorechunk Byte_unsigned, [add_int (transl arg1) (untag_int(transl arg2)); transl arg3])) + | Uprim(Psafegetstringchar, [arg1; arg2]) -> + tag_int + (bind "str" (transl arg1) (fun str -> + bind "index" (untag_int (transl arg2)) (fun idx -> + Csequence( + Cop(Ccheckbound, [string_length str; idx]), + Cop(Cloadchunk Byte_unsigned, [add_int str idx]))))) + | Uprim(Psafesetstringchar, [arg1; arg2; arg3]) -> + return_unit + (bind "str" (transl arg1) (fun str -> + bind "index" (untag_int (transl arg2)) (fun idx -> + Csequence( + Cop(Ccheckbound, [string_length str; idx]), + Cop(Cstorechunk Byte_unsigned, + [add_int str idx; transl arg3]))))) | Uprim(Pvectlength, [arg]) -> - Cop(Cor, [Cop(Clsr, [get_field (transl arg) (-1); Cconst_int 10]); + Cop(Cor, [Cop(Clsr, [get_field (transl arg) (-1); Cconst_int 9]); Cconst_int 1]) | Uprim(Pgetvectitem, [arg1; arg2]) -> Cop(Cload typ_addr, [array_indexing (transl arg1) (transl arg2)]) - | Uprim(Psetvectitem, [arg1; arg2; arg3]) -> - let c = - if is_outside_heap arg3 then - Cop(Cstore, [array_indexing (transl arg1) (transl arg2); - transl arg3]) - else - bind "modify" (transl arg1) (fun loc_var -> - Csequence(Cop(Cmodify, [Cvar loc_var]), - Cop(Cstore, - [array_indexing (Cvar loc_var) (transl arg2); - transl arg3]))) - in return_unit c + | Uprim(Psetvectitem ptr, [arg1; arg2; arg3]) -> + if ptr then + return_unit(Cop(Cextcall("modify", typ_void, false), + [array_indexing (transl arg1) (transl arg2); + transl arg3])) + else + return_unit(Cop(Cstore, [array_indexing (transl arg1) (transl arg2); + transl arg3])) + | Uprim(Psafegetvectitem, [arg1; arg2]) -> + bind "array" (transl arg1) (fun arr -> + bind "index" (transl arg2) (fun idx -> + Csequence( + Cop(Ccheckbound, + [Cop(Clsr, [get_field arr (-1); Cconst_int 9]); idx]), + Cop(Cload typ_addr, [array_indexing arr idx])))) + | Uprim(Psafesetvectitem ptr, [arg1; arg2; arg3]) -> + return_unit + (bind "array" (transl arg1) (fun arr -> + bind "index" (transl arg2) (fun idx -> + Csequence( + Cop(Ccheckbound, + [Cop(Clsr, [get_field arr (-1); Cconst_int 9]); idx]), + if ptr then + Cop(Cextcall("modify", typ_void, false), + [array_indexing arr idx; transl arg3]) + else + Cop(Cstore, [array_indexing arr idx; transl arg3]))))) | Uprim(Ptranslate tbl, [arg]) -> - bind "transl" (transl arg) (fun arg_id -> + bind "transl" (transl arg) (fun arg -> let rec transl_tests lo hi = if lo > hi then int_const 0 else begin let i = (lo + hi) / 2 in let (first_val, last_val, ofs) = tbl.(i) in Cifthenelse( - Cop(Ccmpi Clt, [Cvar arg_id; int_const first_val]), + Cop(Ccmpi Clt, [arg; int_const first_val]), transl_tests lo (i-1), Cifthenelse( - Cop(Ccmpi Cgt, [Cvar arg_id; int_const last_val]), + Cop(Ccmpi Cgt, [arg; int_const last_val]), transl_tests (i+1) hi, - add_const (Cvar arg_id) ((ofs - first_val) * 2))) + add_const arg ((ofs - first_val) * 2))) end in transl_tests 0 (Array.length tbl - 1)) | Uprim(_, _) -> @@ -436,11 +463,11 @@ let rec transl = function else if Array.length const_index = 0 then transl_switch (get_tag (transl arg)) block_index block_cases else - bind "switch" (transl arg) (fun loc_arg -> + bind "switch" (transl arg) (fun arg -> Cifthenelse( - Cop(Cand, [Cvar loc_arg; Cconst_int 1]), - transl_switch (untag_int(Cvar loc_arg)) const_index const_cases, - transl_switch (get_tag(Cvar loc_arg)) block_index block_cases)) + Cop(Cand, [arg; Cconst_int 1]), + transl_switch (untag_int arg) const_index const_cases, + transl_switch (get_tag arg) block_index block_cases)) | Ustaticfail -> Cexit | Ucatch(body, handler) -> @@ -461,16 +488,17 @@ let rec transl = function | Usequence(exp1, exp2) -> Csequence(remove_unit(transl exp1), transl exp2) | Uwhile(cond, body) -> - return_unit(Ccatch(Cloop(exit_if_true cond (transl body)), Ctuple [])) + return_unit(Ccatch(Cloop(exit_if_false cond (remove_unit(transl body))), + Ctuple [])) | Ufor(id, low, high, dir, body) -> let tst = match dir with Upto -> Cgt | Downto -> Clt in let inc = match dir with Upto -> Caddi | Downto -> Csubi in return_unit (Clet(id, transl low, - bind "bound" (transl high) (fun var_high -> + bind "bound" (transl high) (fun high -> Ccatch( Cloop(Cifthenelse( - Cop(Ccmpi tst, [Cvar id; Cvar var_high]), + Cop(Ccmpi tst, [Cvar id; high]), Cexit, Csequence(remove_unit(transl body), Cassign(id, Cop(inc, diff --git a/asmcomp/emit_alpha.mlp b/asmcomp/emit_alpha.mlp index 2d7f90641..65f6297aa 100644 --- a/asmcomp/emit_alpha.mlp +++ b/asmcomp/emit_alpha.mlp @@ -196,6 +196,7 @@ let rec instr_uses_gp i = if n < -0x8000000 or n > 0x7FFFFFFF then true else instr_uses_gp i.next | Lop(Iconst_float s) -> true | Lop(Iconst_symbol s) -> true + | Lop(Iextcall(_, _)) -> true | Lop(Iload(_, Ibased(_, _))) -> true | Lop(Istore(_, Ibased(_, _))) -> true | Lop(Iintop_imm(_, n)) -> @@ -220,7 +221,7 @@ let name_for_int_operation = function | Ilsl -> "sll" | Ilsr -> "srl" | Iasr -> "sra" - | Icomp _ -> Misc.fatal_error "Emit.name_for_int_operation" + | _ -> Misc.fatal_error "Emit.name_for_int_operation" let name_for_specific_operation = function Iadd4 -> "s4addq" @@ -281,7 +282,9 @@ let emit_instr i = ` ldt {emit_reg i.res.(0)}, {emit_stack i.arg.(0)}\n` else ` ldq {emit_reg i.res.(0)}, {emit_stack i.arg.(0)}\n` - | (_, _) -> + | (Stack ss, Stack sd) -> + if ss <> sd then fatal_error "Emit_alpha: Imove stack-stack" + | _ -> fatal_error "Emit_alpha: Imove" end | Lop(Iconst_int 0) -> @@ -322,10 +325,14 @@ let emit_instr i = liveregs i 0; ` br {emit_symbol s}\n` end - | Lop(Iextcall s) -> - ` lda $25, {emit_symbol s}\n`; - liveregs i live_25; - `{record_frame i.live} bsr caml_c_call\n` + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + ` lda $25, {emit_symbol s}\n`; + liveregs i live_25; + `{record_frame i.live} bsr caml_c_call\n` + end else begin + ` jsr {emit_symbol s}\n` + end | Lop(Istackoffset n) -> ` lda $sp, {emit_int (-n)}($sp)\n`; stack_offset := !stack_offset + n @@ -391,15 +398,15 @@ let emit_instr i = liveregs i live_25; ` jsr caml_modify\n` (* Pointer in $25 *) end - | Lop(Icheckbound) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` cmplt {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`; - ` beq {emit_label !range_check_trap}\n` | Lop(Iintop(Icomp cmp)) -> let (comp, test) = name_for_int_comparison cmp in ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`; if not test then ` xor {emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n` + | Lop(Iintop(Icheckbound)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpule {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`; + ` bne $25, {emit_label !range_check_trap}\n` | Lop(Iintop op) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` @@ -408,6 +415,10 @@ let emit_instr i = ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`; if not test then ` xor {emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpule {emit_reg i.arg.(0)}, {emit_int n}, $25\n`; + ` bne $25, {emit_label !range_check_trap}\n` | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` @@ -569,7 +580,7 @@ let fundecl fundecl = List.iter emit_call_gc !call_gc_sites; List.iter emit_modify !modify_sites; if !range_check_trap > 0 then - `{emit_label !range_check_trap}: call_pal PAL_gentrap\n`; + `{emit_label !range_check_trap}: call_pal PAL_gentrap\n`; ` .end {emit_symbol fundecl.fun_name}\n` (* Emission of data *) diff --git a/asmcomp/emit_i386.mlp b/asmcomp/emit_i386.mlp index c9f52db07..1e0948c07 100644 --- a/asmcomp/emit_i386.mlp +++ b/asmcomp/emit_i386.mlp @@ -13,6 +13,22 @@ open Emitaux let fastcode_flag = ref true +let stack_offset = ref 0 + +(* Layout of the stack frame *) + +let frame_size () = (* includes return address *) + !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 + +let slot_offset loc class = + match loc with + Incoming n -> frame_size() + n + | Local n -> + if class = 0 + then !stack_offset + n * 4 + else !stack_offset + num_stack_slots.(0) * 4 + n * 8 + | Outgoing n -> n + (* Symbols are prefixed with _ *) let emit_symbol s = @@ -76,7 +92,7 @@ type frame_descr = let frame_descriptors = ref([] : frame_descr list) -let record_frame live = +let record_frame_label live = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter @@ -91,16 +107,20 @@ let record_frame live = { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset } :: !frame_descriptors; - `{emit_label lbl}:` + lbl + +let record_frame live = + let lbl = record_frame_label live in `{emit_label lbl}:` let emit_frame fd = - ` .long {emit_label fd.fd_lbl} + 4\n`; + ` .long {emit_label fd.fd_lbl}\n`; ` .word {emit_int fd.fd_frame_size}\n`; ` .word {emit_int (List.length fd.fd_live_offset)}\n`; List.iter (fun n -> ` .word {emit_int n}\n`) - fd.fd_live_offset + fd.fd_live_offset; + ` .align 2\n` (* Names for instructions *) @@ -126,8 +146,12 @@ let name_for_cond_branch = function (* Output the assembly code for an instruction *) +(* Name of current function *) let function_name = ref "" +(* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 +(* Label of trap for out-of-range accesses *) +let range_check_trap = ref 0 let float_constants = ref ([] : (int * string) list) @@ -166,9 +190,11 @@ let emit_instr i = | Lop(Iconst_symbol s) -> ` movl ${emit_symbol s}, {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> - `{record_frame i.live} call *{emit_reg i.arg.(0)}\n` + ` call *{emit_reg i.arg.(0)}\n`; + record_frame i.live | Lop(Icall_imm s) -> - `{record_frame i.live} call {emit_symbol s}\n` + ` call {emit_symbol s}\n`; + record_frame i.live | Lop(Itailcall_ind) -> let n = frame_size() - 4 in if n > 0 then @@ -183,9 +209,14 @@ let emit_instr i = ` addl ${emit_int n}, %esp\n`; ` jmp {emit_symbol s}\n` end - | Lop(Iextcall s) -> - ` movl ${emit_symbol s}, %eax\n`; - `{record_frame i.live} call _caml_c_call\n` + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + ` movl ${emit_symbol s}, %eax\n`; + ` call _caml_c_call\n`; + record_frame i.live + end else begin + ` call {emit_symbol s}\n` + end | Lop(Istackoffset n) -> if n >= 0 then ` subl ${emit_int n}, %esp\n` @@ -233,20 +264,20 @@ let emit_instr i = ` subl ${emit_int n}, %eax\n`; ` movl %eax, _young_ptr\n`; ` cmpl _young_start, %eax\n`; - let lbl_cont = new_label() in + let lbl_cont = record_frame_label i.live in ` jae {emit_label lbl_cont}\n`; ` movl ${emit_int n}, %eax\n`; - `{record_frame i.live} call _caml_call_gc\n`; + ` call _caml_call_gc\n`; `{emit_label lbl_cont}: leal 4(%eax), {emit_reg i.res.(0)}\n` end else begin begin match n with - 8 -> `{record_frame i.live} call _caml_alloc1\n` - | 12 -> `{record_frame i.live} call _caml_alloc2\n` - | 16 -> `{record_frame i.live} call _caml_alloc3\n` + 8 -> ` call _caml_alloc1\n` + | 12 -> ` call _caml_alloc2\n` + | 16 -> ` call _caml_alloc3\n` | _ -> ` movl ${emit_int n}, %eax\n`; - `{record_frame i.live} call _caml_alloc\n` + ` call _caml_alloc\n` end; - ` leal 4(%eax), {emit_reg i.res.(0)}\n` + `{record_frame i.live} leal 4(%eax), {emit_reg i.res.(0)}\n` end | Lop(Imodify) -> (* Argument is in eax *) @@ -268,6 +299,14 @@ let emit_instr i = let b = name_for_cond_branch cmp in ` set{emit_string b} %al\n`; ` movzbl %al, {emit_reg i.res.(0)}\n` + | Lop(Iintop Icheckbound) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + ` jbe {emit_label !range_check_trap}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; + ` jbe {emit_label !range_check_trap}\n` | Lop(Iintop(Idiv | Imod)) -> ` cltd\n`; ` idivl {emit_reg i.arg.(1)}\n` @@ -365,6 +404,13 @@ let emit_instr i = let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Ifloattest cmp -> + ` fldl {emit_reg i.arg.(0)}\n`; + begin match i.arg.(1).loc with + Stack s -> + ` fcompl {emit_shift i.arg.(1)}\n` + | _ -> + ` fcomp {emit_shift i.arg.(1)}\n` + end; ` fnstsw %ax\n`; match cmp with Ceq -> @@ -410,22 +456,20 @@ let emit_instr i = ` .long {emit_label jumptbl.(i)}\n` done end - | Lpushtrap lbl -> + | Lsetuptrap lbl -> + ` call {emit_label lbl}\n` + | Lpushtrap -> ` pushl _caml_exception_pointer\n`; - ` pushl ${emit_label lbl}\n`; ` movl %esp, _caml_exception_pointer\n`; stack_offset := !stack_offset + 8 | Lpoptrap -> - ` addl $4, %esp\n`; ` popl _caml_exception_pointer\n`; + ` addl $4, %esp\n`; stack_offset := !stack_offset - 8 - | Lentertrap -> - () | Lraise -> ` movl _caml_exception_pointer, %esp\n`; - ` popl %edx\n`; ` popl _caml_exception_pointer\n`; - ` jmp *%edx\n` + ` ret\n` let rec emit_all i = match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next @@ -444,6 +488,7 @@ let fundecl fundecl = tailrec_entry_point := new_label(); stack_offset := 0; float_constants := []; + range_check_trap := 0; ` .text\n`; ` .align 4\n`; ` .globl {emit_symbol fundecl.fun_name}\n`; @@ -453,6 +498,8 @@ let fundecl fundecl = ` subl ${emit_int n}, %esp\n`; `{emit_label !tailrec_entry_point}:`; emit_all fundecl.fun_body; + if !range_check_trap > 0 then + `{emit_label !range_check_trap}: int $5\n` List.iter emit_float_constant !float_constants (* Emission of data *) diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index c2a19dcd5..0dbb74d9a 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -76,7 +76,7 @@ let rec live i finally = let across_after = Reg.diff_set_array (live i.next finally) i.res in let across = match i.desc with - Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall _)-> + Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall(_, _)) -> (* The function call may raise an exception, branching to the nearest enclosing try ... with. Hence, everything that must be live at the beginning of the exception handler must also diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index d7a0ee7cf..708d52689 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -8,6 +8,7 @@ type integer_operation = Iadd | Isub | Imul | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison + | Icheckbound type test = Itruetest @@ -27,7 +28,7 @@ type operation = | Icall_imm of string | Itailcall_ind | Itailcall_imm of string - | Iextcall of string + | Iextcall of string * bool | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode | Istore of Cmm.memory_chunk * Arch.addressing_mode @@ -37,7 +38,6 @@ type operation = | Iintop_imm of integer_operation * int | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iintoffloat - | Icheckbound | Ispecific of Arch.specific_operation type instruction = diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index 83c2c2fa6..130d16abd 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -8,6 +8,7 @@ type integer_operation = Iadd | Isub | Imul | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison + | Icheckbound type test = Itruetest @@ -27,7 +28,7 @@ type operation = | Icall_imm of string | Itailcall_ind | Itailcall_imm of string - | Iextcall of string + | Iextcall of string * bool | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode | Istore of Cmm.memory_chunk * Arch.addressing_mode @@ -37,7 +38,6 @@ type operation = | Iintop_imm of integer_operation * int | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iintoffloat - | Icheckbound | Ispecific of Arch.specific_operation type instruction = diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index 91210e613..578ce81b8 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -33,7 +33,7 @@ let chunk = function let operation = function Capply ty -> print_string "app" - | Cextcall(lbl, ty) -> + | Cextcall(lbl, ty, alloc) -> print_string "extcall \""; print_string lbl; print_string "\"" | Cproj(ofs, len) -> print_string "proj "; print_int ofs; @@ -127,7 +127,7 @@ let rec expression = function List.iter (fun e -> print_space(); expression e) el; begin match op with Capply mty -> print_space(); machtype mty - | Cextcall(_, mty) -> print_space(); machtype mty + | Cextcall(_, mty, _) -> print_space(); machtype mty | Cload mty -> print_space(); machtype mty | _ -> () end; diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index e351e3bc4..86de689bc 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -13,7 +13,7 @@ let instr i = Lend -> () | Lop op -> begin match op with - Ialloc _ | Icall_ind | Icall_imm _ | Iextcall _ -> + Ialloc _ | Icall_ind | Icall_imm _ | Iextcall(_, _) -> open_hovbox 1; print_string "{"; regsetaddr i.live; diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 23c3fd7cc..fea9797f9 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -68,6 +68,7 @@ let intop = function | Ilsr -> print_string " >>u " | Iasr -> print_string " >>s " | Icomp cmp -> intcomp cmp + | Icheckbound -> print_string " check > " let test tst arg = match tst with @@ -96,9 +97,10 @@ let operation op arg res = | Itailcall_imm lbl -> print_string "tailcall \""; print_string lbl; print_string "\" "; regs arg - | Iextcall lbl -> + | Iextcall(lbl, alloc) -> print_string "extcall \""; print_string lbl; - print_string "\" "; regs arg + print_string "\" "; regs arg; + if not alloc then print_string " (noalloc)" | Istackoffset n -> print_string "offset stack "; print_int n | Iload(chunk, addr) -> @@ -122,8 +124,6 @@ let operation op arg res = | Idivf -> reg arg.(0); print_string " /f "; reg arg.(1) | Ifloatofint -> print_string "floatofint "; reg arg.(0) | Iintoffloat -> print_string "intoffloat "; reg arg.(0) - | Icheckbound -> - print_string "check "; reg arg.(0); print_string " < "; reg arg.(1) | Ispecific op -> Arch.print_specific_operation reg op arg diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index 673b64521..0066794dc 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -35,8 +35,8 @@ val loc_exn_bucket: Reg.t (* Maximal register pressures for pre-spilling *) -val safe_register_pressure: int -val max_register_pressure: int array +val safe_register_pressure: Mach.operation -> int +val max_register_pressure: Mach.operation -> int array (* Registers destroyed by operations *) val destroyed_at_oper: Mach.instruction_desc -> Reg.t array diff --git a/asmcomp/proc_alpha.ml b/asmcomp/proc_alpha.ml index cdbf0387d..d06b69139 100644 --- a/asmcomp/proc_alpha.ml +++ b/asmcomp/proc_alpha.ml @@ -19,6 +19,8 @@ let select_addressing = function (Ibased(s, n), Ctuple []) | Cop(Cadda, [arg; Cconst_int n]) -> (Iindexed n, arg) + | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> + (Iindexed n, Cop(Cadda, [arg1; arg2])) | arg -> (Iindexed 0, arg) @@ -193,17 +195,27 @@ let loc_exn_bucket = phys_reg 0 (* $0 *) (* Registers destroyed by operations *) +let destroyed_at_c_call = (* $9 - $12, $f2 - $f9 preserved *) + Array.of_list(List.map phys_reg + [0;1;2;3;4;5;6;7;8;13;14;15;16;17;18;19;20; + 100;101;110;111;112;113;114;115;116;117;118;119;120;121;122;123;124; + 125;126;127;128;129]) + let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall _) -> all_phys_regs + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call | _ -> [||] let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) -let max_register_pressure = [| 20; 29 |] - -let safe_register_pressure = 20 +let safe_register_pressure = function + Iextcall(_, _) -> 4 + | _ -> 20 +let max_register_pressure = function + Iextcall(_, _) -> [| 4; 8 |] + | _ -> [| 20; 29 |] (* Reloading *) @@ -235,4 +247,4 @@ let slot_offset loc class = (* Calling the assembler *) let assemble_file infile outfile = - Sys.command ("as -nocpp -O2 -o " ^ outfile ^ " " ^ infile) + Sys.command ("as -O2 -o " ^ outfile ^ " " ^ infile) diff --git a/asmcomp/proc_i386.ml b/asmcomp/proc_i386.ml index 933d17998..b05a37c0c 100644 --- a/asmcomp/proc_i386.ml +++ b/asmcomp/proc_i386.ml @@ -258,8 +258,12 @@ let loc_exn_bucket = phys_reg 0 (* eax *) (* Registers destroyed by operations *) +let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) + Array.of_list(List.map phys_reg [0;2;3;100;101;102;103]) + let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall _) -> all_phys_regs + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call | Iop(Iintop(Idiv | Imod)) -> [| phys_reg 0; phys_reg 3 |] (* eax, edx *) | Iop(Ialloc _) -> [| phys_reg 0|] (* eax *) | Iop(Imodify) -> [| phys_reg 0 |] (* eax *) @@ -272,9 +276,14 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) -let max_register_pressure = [|7; 4|] +let safe_register_pressure op = 4 -let safe_register_pressure = 4 +let max_register_pressure = function + Iextcall(_, _) -> [| 4; 4 |] + | Iintop(Idiv | Imod) -> [| 5; 4 |] + | Ialloc _ | Imodify | Iintop(Icomp _) | Iintop_imm(Icomp _, _) | + Iintoffloat -> [| 6; 4 |] + | _ -> [|7; 4|] (* Reloading of instruction arguments, storing of instruction results *) @@ -293,7 +302,7 @@ let reload_test makereg tst arg = let reload_operation makereg op arg res = match op with - Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor|Icomp _) -> + Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor|Icomp _|Icheckbound) -> (* One of the two arguments can reside in the stack *) if stackp arg.(0) & stackp arg.(1) then ([|arg.(0); makereg arg.(1)|], res) @@ -308,21 +317,8 @@ let reload_operation makereg op arg res = (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] -let stack_offset = ref 0 let contains_calls = ref false -let frame_size () = (* includes return address *) - !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 - -let slot_offset loc class = - match loc with - Incoming n -> frame_size() + n - | Local n -> - if class = 0 - then !stack_offset + n * 4 - else !stack_offset + num_stack_slots.(0) * 4 + n * 8 - | Outgoing n -> n - (* Calling the assembler *) let assemble_file infile outfile = diff --git a/asmcomp/reload.ml b/asmcomp/reload.ml index 0d4f493c3..557bcf942 100644 --- a/asmcomp/reload.ml +++ b/asmcomp/reload.ml @@ -43,7 +43,7 @@ let insert_moves src dst next = let rec reload i = match i.desc with Iend | Ireturn | Iop Itailcall_ind | Iop(Itailcall_imm _) | Iraise -> i - | Iop(Icall_ind | Icall_imm _ | Iextcall _) -> + | Iop(Icall_ind | Icall_imm _ | Iextcall(_, _)) -> (* Don't do anything, the arguments and results are already at the correct position (e.g. on stack for some arguments). *) instr_cons_live i.desc i.arg i.res i.live (reload i.next) diff --git a/asmcomp/selection.ml b/asmcomp/selection.ml index 7133b87ba..71daa753b 100644 --- a/asmcomp/selection.ml +++ b/asmcomp/selection.ml @@ -10,7 +10,7 @@ open Mach let oper_result_type = function Capply ty -> ty - | Cextcall(s, ty) -> ty + | Cextcall(s, ty, alloc) -> ty | Cload ty -> ty | Cloadchunk c -> typ_int | Calloc -> typ_addr @@ -51,7 +51,7 @@ let rec size_expr env = function (* Says if an operation is "safe", i.e. without side-effects *) let safe_operation = function - Capply _ | Cextcall(_, _) | Calloc | Cstore | Cstorechunk _ | + Capply _ | Cextcall(_, _, _) | Calloc | Cstore | Cstorechunk _ | Cmodify | Craise -> false | _ -> true @@ -61,7 +61,7 @@ let rec sel_operation op args = match (op, args) with (Capply ty, Cconst_symbol s :: rem) -> (Icall_imm s, rem) | (Capply ty, _) -> (Icall_ind, args) - | (Cextcall(s, ty), _) -> (Iextcall s, args) + | (Cextcall(s, ty, alloc), _) -> (Iextcall(s, alloc), args) | (Cload ty, [arg]) -> let (addr, eloc) = Proc.select_addressing arg in (Iload(Word, addr), [eloc]) @@ -97,7 +97,7 @@ let rec sel_operation op args = | (Cdivf, _) -> (Idivf, args) | (Cfloatofint, _) -> (Ifloatofint, args) | (Cintoffloat, _) -> (Iintoffloat, args) - | (Ccheckbound, _) -> (Icheckbound, args) + | (Ccheckbound, _) -> sel_arith Icheckbound args | _ -> fatal_error "Selection.sel_oper" and sel_arith_comm op = function @@ -337,14 +337,14 @@ let rec emit_expr env exp seq = insert (Iop(Icall_imm lbl)) loc_arg loc_res seq; insert_move_results loc_res rd stack_ofs seq; rd - | Iextcall lbl -> + | Iextcall(lbl, alloc) -> Proc.contains_calls := true; let r1 = emit_tuple env new_args 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 (Iop(Iextcall(lbl, alloc))) loc_arg loc_res seq; insert_move_results loc_res rd stack_ofs seq; rd | Iload(Word, addr) -> diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 4cfdc708d..ff5126f8d 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -48,7 +48,8 @@ let record_use regv = (* Check if the register pressure overflows the maximum pressure allowed at that point. If so, spill enough registers to lower the pressure. *) -let add_superpressure_regs live_regs res_regs spilled = +let add_superpressure_regs op live_regs res_regs spilled = + let max_pressure = Proc.max_register_pressure op in let regs = Reg.add_set_array live_regs res_regs in (* Compute the pressure in each register class *) let pressure = Array.new Proc.num_register_classes 0 in @@ -63,15 +64,17 @@ let add_superpressure_regs live_regs res_regs spilled = let rec check_pressure class spilled = if class >= Proc.num_register_classes then spilled - else if pressure.(class) <= Proc.max_register_pressure.(class) then + else if pressure.(class) <= max_pressure.(class) then check_pressure (class+1) spilled else begin - (* Find the least recently used, unspilled register in the class *) + (* Find the least recently used, unspilled, unallocated, live register + in the class *) let lru_date = ref 1000000 and lru_reg = ref Reg.dummy in Reg.Set.iter (fun r -> if Proc.register_class r = class & - not (Reg.Set.mem r spilled) then begin + not (Reg.Set.mem r spilled) & + r.loc = Unknown then begin try let d = Reg.Map.find r !use_date in if d < !lru_date then begin @@ -81,7 +84,7 @@ let add_superpressure_regs live_regs res_regs spilled = with Not_found -> (* Should not happen *) () end) - regs; + live_regs; pressure.(class) <- pressure.(class) - 1; check_pressure class (Reg.Set.add !lru_reg spilled) end in @@ -108,7 +111,7 @@ let rec reload i before = | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) - | Iop(Icall_ind | Icall_imm _ | Iextcall _) -> + | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> (* All regs live across must be spilled *) let (new_next, finally) = reload i.next i.live in (add_reloads (Reg.inter_set_array before i.arg) @@ -118,9 +121,9 @@ let rec reload i before = let new_before = (* Quick check to see if the register pressure is below the maximum *) if Reg.Set.cardinal i.live + Array.length i.res <= - Proc.safe_register_pressure + Proc.safe_register_pressure op then before - else add_superpressure_regs i.live i.res before in + else add_superpressure_regs op i.live i.res before in let after = Reg.diff_set_array (Reg.diff_set_array new_before i.arg) i.res in let (new_next, finally) = reload i.next after in @@ -233,7 +236,7 @@ let rec spill i finally = let before1 = Reg.diff_set_array after i.res in let before = match i.desc with - Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall _) -> + Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall(_, _)) -> Reg.Set.union before1 !spill_at_raise | _ -> before1 in diff --git a/asmrun/Makefile b/asmrun/Makefile index ea90c00bd..088878264 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -1,23 +1,50 @@ -ARCH=alpha -CC=gcc -CFLAGS=-O2 -D$(ARCH) -Wall -#CFLAGS=-g -DDEBUG -Wall -AS=as -ASFLAGS=-O2 +include ../config/Makefile.h +include ../Makefile.config -OBJS=runtime.o gc.o debug.o compare.o $(ARCH).o +CFLAGS=-I../byterun -DTARGET_$(ARCH) -O $(CCCOMPOPTS) +DFLAGS=-I../../byterun -DTARGET_$(ARCH) -g -DDEBUG $(CCCOMPOPTS) -librun.a: $(OBJS) - rm -f librun.a - ar rc librun.a $(OBJS) - ranlib librun.a +COBJS=fail.o main.o roots.o signals.o +ASMOBJS=$(ARCH).o +OTHEROBJS=../byterun/misc.o ../byterun/freelist.o \ + ../byterun/major_gc.o ../byterun/minor_gc.o ../byterun/memory.o \ + ../byterun/alloc.o ../byterun/compare.o \ + ../byterun/ints.o ../byterun/floats.o ../byterun/str.o \ + ../byterun/array.o ../byterun/io.o ../byterun/extern.o \ + ../byterun/intern.o ../byterun/hash.o ../byterun/sys.o \ + ../byterun/parsing.o ../byterun/lexing.o ../byterun/gc_ctrl.o \ + ../byterun/terminfo.o ../byterun/crc.o -.SUFFIXES: .asm .o +OBJS=$(COBJS) $(ASMOBJS) $(OTHEROBJS) +DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS) $(OTHEROBJS:.o=.d.o) + +all: libasmrun.a libasmrund.a + +libasmrun.a: $(OBJS) + rm -f libasmrun.a + ar rc libasmrun.a $(OBJS) + $(RANLIB) libasmrun.a + +libasmrund.a: $(DOBJS) + rm -f libasmrund.a + ar rc libasmrund.a $(DOBJS) + $(RANLIB) libasmrund.a + +.SUFFIXES: .asm .d.o .asm.o: $(AS) $(ASFLAGS) -o $*.o $*.asm +.c.d.o: + cd .debugobj; $(CC) -c $(DFLAGS) -I.. ../$< + mv .debugobj/$*.o $*.d.o + clean:: rm -f *.o *.s *.a *~ -runtime.o gc.o compare.o debug.o: mlvalues.h misc.h +depend: + gcc -MM $(CFLAGS) *.c > .depend + gcc -MM $(DFLAGS) *.c | sed -e 's/\.o/.d.o/' >> .depend + +include .depend + diff --git a/asmrun/alpha.asm b/asmrun/alpha.asm index e46425099..06eddc40b 100644 --- a/asmrun/alpha.asm +++ b/asmrun/alpha.asm @@ -89,42 +89,45 @@ caml_alloc: ret ($26) caml_call_gc: - lda $sp, -16($sp) + lda $sp, -32($sp) stq $26, 0($sp) stq $gp, 8($sp) + stq $25, 16($sp) /* Rebuild $gp */ br $27, $103 $103: ldgp $gp, 0($27) /* Record lowest stack address and return address */ ldq $24, 0($sp) stq $24, caml_last_return_address - lda $24, 16($sp) + lda $24, 32($sp) stq $24, caml_bottom_of_stack /* Save current allocation pointer for debugging purposes */ stq $13, young_ptr /* Save all regs used by the code generator in the arrays /* gc_entry_regs and gc_entry_float_regs. */ SAVE_ALL_REGS - /* Pass the desired size as first argument */ - mov $25, $16 /* Call the garbage collector */ - jsr garbage_collection + jsr minor_collection /* Restore all regs used by the code generator */ ldgp $gp, 0($26) LOAD_ALL_REGS /* Reload new allocation pointer and allocation limit */ ldq $13, young_ptr ldq $14, young_start + /* Allocate space for the block */ + ldq $25, 16($sp) + subq $13, $25, $13 /* Return to caller */ ldq $26, 0($sp) ldq $gp, 8($sp) - lda $sp, 16($sp) + lda $sp, 32($sp) ret ($26) .end caml_alloc1 /* Modification */ +#if 0 .globl caml_modify .globl caml_fast_modify .ent caml_modify @@ -177,6 +180,7 @@ caml_modify_realloc: ret ($26) .end caml_modify +#endif /* Call a C function from Caml */ diff --git a/asmrun/fail.c b/asmrun/fail.c new file mode 100644 index 000000000..1f074b773 --- /dev/null +++ b/asmrun/fail.c @@ -0,0 +1,146 @@ +/* Raising exceptions from C. */ + +#include "alloc.h" +#include "fail.h" +#include "gc.h" +#include "memory.h" +#include "mlvalues.h" +#include "roots.h" +#include "signals.h" +#include "stacks.h" + +/* For minor_gc.c */ +struct longjmp_buffer * external_raise; + +/* The globals holding predefined exceptions */ + +value Out_of_memory, Sys_error, Failure, Invalid_argument; +value End_of_file, Division_by_zero, Not_found, Match_failure; + +/* Initialize the predefined exceptions */ + +static struct { value * loc; char * name; } predefined_exceptions[] = { + &Out_of_memory, "Out_of_memory", + &Sys_error, "Sys_error", + &Failure, "Failure", + &Invalid_argument, "Invalid_argument", + &End_of_file, "End_of_file", + &Division_by_zero, "Division_by_zero", + &Not_found, "Not_found", + &Match_failure, "Match_failure", + NULL, NULL +}; + +void init_exceptions() +{ + int i; + value * loc; + value exn_bucket; + Push_roots(r, 1); + for (i = 0; predefined_exceptions[i].loc != NULL; i++) { + r[0] = copy_string(predefined_exceptions[i].name); + exn_bucket = alloc(1, 0); + Field(exn_bucket, 0) = r[0]; + loc = predefined_exceptions[i].loc; + *loc = exn_bucket; + register_global_root(loc); + } + Pop_roots(); +} + +/* Exception raising */ + +extern void raise_caml_exception P((value bucket)) Noreturn; + +void mlraise(v) + value v; +{ + leave_blocking_section(); + raise_caml_exception(v); +} + +void raise_constant(tag) + value tag; +{ + value bucket; + Push_roots (a, 1); + a[0] = tag; + bucket = alloc (1, 0); + Field(bucket, 0) = a[0]; + Pop_roots (); + mlraise(bucket); +} + +void raise_with_arg(tag, arg) + value tag; + value arg; +{ + value bucket; + Push_roots (a, 2); + a[0] = tag; + a[1] = arg; + bucket = alloc (2, 0); + Field(bucket, 0) = a[0]; + Field(bucket, 1) = a[1]; + Pop_roots (); + mlraise(bucket); +} + +void raise_with_string(tag, msg) + value tag; + char * msg; +{ + raise_with_arg(tag, copy_string(msg)); +} + +void failwith (msg) + char * msg; +{ + raise_with_string(Failure, msg); +} + +void invalid_argument (msg) + char * msg; +{ + raise_with_string(Invalid_argument, msg); +} + +/* To raise Out_of_memory, we can't use raise_constant, + because it allocates and we're out of memory... + We therefore build the bucket by hand. + This works OK because the exception value for Out_of_memory is also + statically allocated out of the heap. */ + +static struct { + header_t hdr; + value exn; +} out_of_memory_bucket; + +void raise_out_of_memory() +{ + out_of_memory_bucket.hdr = Make_header(1, 0, White); + out_of_memory_bucket.exn = Out_of_memory; + mlraise((value) &(out_of_memory_bucket.exn)); +} + +void raise_sys_error(msg) + value msg; +{ + raise_with_arg(Sys_error, msg); +} + +void raise_end_of_file() +{ + raise_constant(End_of_file); +} + +void raise_zero_divide() +{ + raise_constant(Division_by_zero); +} + +void raise_not_found() +{ + raise_constant(Not_found); +} + diff --git a/asmrun/i386.asm b/asmrun/i386.asm index d69c7f78b..20f8cc86c 100644 --- a/asmrun/i386.asm +++ b/asmrun/i386.asm @@ -4,6 +4,7 @@ .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 @@ -74,11 +75,10 @@ _caml_call_gc: movl %esi, _gc_entry_regs + 16 movl %edi, _gc_entry_regs + 20 movl %ebp, _gc_entry_regs + 24 - # Pass the desired size as first argument + # Save desired size pushl %eax # Call the garbage collector - call _garbage_collection - add $4, %esp + call _minor_collection # Restore all regs used by the code generator movl _gc_entry_regs + 4, %ebx movl _gc_entry_regs + 8, %ecx @@ -86,6 +86,9 @@ _caml_call_gc: 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 @@ -94,35 +97,35 @@ _caml_call_gc: # Modification - .globl _caml_modify - .globl _caml_fast_modify - - .align 4 -_caml_modify: - testb $4, -3(%eax) - jz _caml_fast_modify - ret - -_caml_fast_modify: - # Store address of object in remembered set - pushl %eax - movl _remembered_ptr, %eax - popl (%eax) - addl $4, %eax - movl %eax, _remembered_ptr - cmpl _remembered_end, %eax - ja _caml_modify_realloc - ret - -_caml_modify_realloc: - # Reallocate the remembered set while preserving all regs - pushl %ecx - pushl %edx - # (%eax dead, %ebx, %esi, %edi, %ebp preserved by C) - call _realloc_remembered - popl %edx - popl %ecx - ret +# .globl _caml_modify +# .globl _caml_fast_modify +# +# .align 4 +#_caml_modify: +# testb $4, -3(%eax) +# jz _caml_fast_modify +# ret +# +#_caml_fast_modify: +# # Store address of object in remembered set +# pushl %eax +# movl _remembered_ptr, %eax +# popl (%eax) +# addl $4, %eax +# movl %eax, _remembered_ptr +# cmpl _remembered_end, %eax +# ja _caml_modify_realloc +# ret +# +#_caml_modify_realloc: +# # Reallocate the remembered set while preserving all regs +# pushl %ecx +# pushl %edx +# # (%eax dead, %ebx, %esi, %edi, %ebp preserved by C) +# call _realloc_remembered +# popl %edx +# popl %ecx +# ret # Call a C function from Caml @@ -150,9 +153,11 @@ _caml_start_program: pushl %edi pushl %ebp # Build an exception handler - pushl $0 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 diff --git a/asmrun/main.c b/asmrun/main.c new file mode 100644 index 000000000..be9cca81a --- /dev/null +++ b/asmrun/main.c @@ -0,0 +1,58 @@ +/* Start-up code */ + +#include <stdio.h> +#include <stdlib.h> +#include "gc.h" +#include "gc_ctrl.h" +#include "misc.h" +#include "mlvalues.h" +#include "sys.h" + +header_t first_atoms[256]; + +static void init_atoms() +{ + int i; + for(i = 0; i < 256; i++) first_atoms[i] = Make_header(0, i, White); +} + +extern value caml_start_program P((void)); + +int main(argc, argv) + int argc; + char * argv[]; +{ + int verbose_init = 0, percent_free_init = Percent_free_def; + long minor_heap_init = Minor_heap_def, heap_chunk_init = Heap_chunk_def; + char * opt; + value retcode; + +#ifdef DEBUG + verbose_init = 1; +#endif + /* Runtime options. The option letter is the first letter of the + last word of the ML name of the option (see [lib/gc.mli]). */ + opt = getenv ("CAMLRUNPARAM"); + if (opt != NULL){ + while (*opt != '\0'){ + switch (*opt++){ + case 's': sscanf (opt, "=%ld", &minor_heap_init); break; + case 'i': sscanf (opt, "=%ld", &heap_chunk_init); break; + case 'o': sscanf (opt, "=%d", &percent_free_init); break; + case 'v': sscanf (opt, "=%d", &verbose_init); break; + } + } + } + init_gc (minor_heap_init, heap_chunk_init, percent_free_init, verbose_init); + init_atoms(); + init_exceptions(); + sys_init(argv); + retcode = caml_start_program(); + if (retcode == 0) { + sys_exit(Val_int(0)); + } else { + fatal_error_arg("Fatal error: uncaught exception %s.\n", + String_val(Field(Field(retcode, 0), 0))); + } +} + diff --git a/asmrun/roots.c b/asmrun/roots.c new file mode 100644 index 000000000..95c2949df --- /dev/null +++ b/asmrun/roots.c @@ -0,0 +1,240 @@ +/* To walk the memory roots for garbage collection */ + +#include "memory.h" +#include "major_gc.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "roots.h" +#include "stacks.h" + +/* Machine-dependent macros to access the stack frames */ + +#ifdef TARGET_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 Mask_already_scanned(retaddr) (retaddr & ~1) +#endif + +#ifdef TARGET_i386 +#define Saved_return_address(sp) *((long *)(sp - 4)) +#endif + +/* Roots registered from C functions */ + +value * local_roots = NULL; + +struct global_root { + value * root; + struct global_root * next; +}; + +static struct global_root * global_roots = NULL; + +/* Register a global C root */ + +void register_global_root(r) + value * r; +{ + struct global_root * gr; + gr = (struct global_root *) stat_alloc(sizeof(struct global_root)); + gr->root = r; + gr->next = global_roots; + global_roots = gr; +} + +/* 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) >> 3) & 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 + 2 times the number of descriptors */ + tblsize = 4; + while (tblsize < 2 * num_descr) tblsize *= 2; + + /* Allocate the hash table */ + frame_descriptors = + (frame_descr **) stat_alloc(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 *)); + } + } +} + +/* Communication with [caml_start_program] and [caml_call_gc]. */ + +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[]; + +/* Call [oldify] on all stack roots, C roots and global roots */ + +void oldify_local_roots () +{ + char * sp; + unsigned long retaddr; + frame_descr * d; + unsigned long h; + int i, n, ofs; + short * p; + value * root; + value * block; + struct global_root * gr; + + /* The global roots */ + for (i = 0; caml_globals[i] != 0; i++) + oldify(caml_globals[i], *(caml_globals[i])); + + /* The stack */ + 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]; + } + oldify(root, *root); + } + /* Move to next frame */ + sp += d->frame_size; + retaddr = Saved_return_address(sp); +#ifdef Already_scanned + /* Stop here if the frame has already been scanned during earlier GCs */ + if (Already_scanned(sp, retaddr)) break; + /* Mark frame as already scanned */ + Mark_scanned(sp, retaddr); +#endif + } + /* Local C roots */ + for (block = local_roots; block != NULL; block = (value *) block [1]){ + for (root = block - (long) block [0]; root < block; root++){ + oldify (root, *root); + } + } + /* Global C roots */ + for (gr = global_roots; gr != NULL; gr = gr->next) { + oldify(gr->root, *(gr->root)); + } +} + +/* Call [darken] on all roots */ + +void darken_all_roots () +{ + char * sp; + unsigned long retaddr; + frame_descr * d; + unsigned long h; + int i, n, ofs; + short * p; + value * root; + value * block; + struct global_root * gr; + + /* The global roots */ + for (i = 0; caml_globals[i] != 0; i++) + darken(*(caml_globals[i])); + + /* The stack */ + 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]; + } + darken(*root); + } + /* Move to next frame */ + sp += d->frame_size; + retaddr = Saved_return_address(sp); +#ifdef Mask_already_scanned + retaddr = Mask_already_scanned(retaddr); +#endif + } + Assert(sp == caml_top_of_stack); + + /* Local C roots */ + for (block = local_roots; block != NULL; block = (value *) block [1]){ + for (root = block - (long) block [0]; root < block; root++){ + darken (*root); + } + } + /* Global C roots */ + for (gr = global_roots; gr != NULL; gr = gr->next) { + darken (*(gr->root)); + } +} + diff --git a/asmrun/signals.c b/asmrun/signals.c new file mode 100644 index 000000000..ad97e677a --- /dev/null +++ b/asmrun/signals.c @@ -0,0 +1,18 @@ +#include "misc.h" +#include "mlvalues.h" +#include "signals.h" + +void enter_blocking_section() +{ +} + +void leave_blocking_section() +{ +} + +value install_signal_handler(signal_number, action) /* ML */ + value signal_number, action; +{ + invalid_argument("Sys.signal: not implemented"); + return Val_unit; +} diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 32066209f..aa331b9dd 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -242,8 +242,8 @@ let rec comp_expr env exp sz cont = | 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) + | Psetfield(n, ptr) -> Ksetfield n + | Pccall(name, n, alloc) -> Kccall(name, n) | Pnegint -> Knegint | Paddint -> Kaddint | Psubint -> Ksubint @@ -269,11 +269,16 @@ let rec comp_expr env exp sz cont = | Pfloatcomp Cgt -> Kccall("gt_float", 2) | Pfloatcomp Cle -> Kccall("le_float", 2) | Pfloatcomp Cge -> Kccall("ge_float", 2) + | Pstringlength -> Kccall("ml_string_length", 1) + | Psafegetstringchar -> Kccall("string_get", 2) + | Psafesetstringchar -> Kccall("string_set", 3) | Pgetstringchar -> Kgetstringchar | Psetstringchar -> Ksetstringchar | Pvectlength -> Kvectlength + | Psafegetvectitem -> Kccall("array_get", 2) + | Psafesetvectitem ptr -> Kccall("array_set", 3) | Pgetvectitem -> Kgetvectitem - | Psetvectitem -> Ksetvectitem + | Psetvectitem ptr -> Ksetvectitem | Ptranslate tbl -> Ktranslate tbl | _ -> fatal_error "Codegen.comp_expr: prim" in comp_args env args sz (instr :: cont) diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index dba6eaac3..59fbe8290 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -8,8 +8,8 @@ type primitive = | Psetglobal of Ident.t | Pmakeblock of int | Pfield of int - | Psetfield of int - | Pccall of string * int + | Psetfield of int * bool + | Pccall of string * int * bool | Praise | Psequand | Psequor | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint @@ -20,8 +20,10 @@ type primitive = | Poffsetref of int | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pfloatcomp of comparison - | Pgetstringchar | Psetstringchar - | Pvectlength | Pgetvectitem | Psetvectitem + | Pstringlength | Pgetstringchar | Psetstringchar + | Psafegetstringchar | Psafesetstringchar + | Pvectlength | Pgetvectitem | Psetvectitem of bool + | Psafegetvectitem | Psafesetvectitem of bool | Ptranslate of (int * int * int) array and comparison = diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index b9c46a4e5..422da58d2 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -8,8 +8,8 @@ type primitive = | Psetglobal of Ident.t | Pmakeblock of int | Pfield of int - | Psetfield of int - | Pccall of string * int + | Psetfield of int * bool + | Pccall of string * int * bool | Praise | Psequand | Psequor | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint @@ -20,8 +20,10 @@ type primitive = | Poffsetref of int | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pfloatcomp of comparison - | Pgetstringchar | Psetstringchar - | Pvectlength | Pgetvectitem | Psetvectitem + | Pstringlength | Pgetstringchar | Psetstringchar + | Psafegetstringchar | Psafesetstringchar + | Pvectlength | Pgetvectitem | Psetvectitem of bool + | Psafegetvectitem | Psafesetvectitem of bool | Ptranslate of (int * int * int) array and comparison = diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index e4765b72d..b1ec4c2cf 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -165,7 +165,8 @@ let combine_constant arg cst (const_lambda_list, total1) (lambda2, total2) = Lswitch(Lprim(Ptranslate transl_table, [arg]), num_actions, actions, 0, []) | Const_string _ -> - make_test_sequence (Pccall("equal", 2)) arg const_lambda_list + make_test_sequence (Pccall("string_equal", 2, false)) + arg const_lambda_list | Const_float _ -> make_test_sequence (Pfloatcomp Ceq) arg const_lambda_list in (Lcatch(lambda1, lambda2), total2) diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index d8c7ad12b..884e70451 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -31,8 +31,8 @@ let primitive = function | Psetglobal id -> print_string "setglobal "; Ident.print id | Pmakeblock tag -> print_string "makeblock "; print_int tag | Pfield n -> print_string "field "; print_int n - | Psetfield n -> print_string "setfield "; print_int n - | Pccall(name, arity) -> print_string name + | Psetfield(n, _) -> print_string "setfield "; print_int n + | Pccall(name, arity, alloc) -> print_string name | Praise -> print_string "raise" | Psequand -> print_string "&&" | Psequor -> print_string "||" @@ -68,11 +68,16 @@ let primitive = function | Pfloatcomp(Cle) -> print_string "<=." | Pfloatcomp(Cgt) -> print_string ">." | Pfloatcomp(Cge) -> print_string ">=." - | Pgetstringchar -> print_string "string.get" - | Psetstringchar -> print_string "string.set" + | Pstringlength -> print_string "string.length" + | Pgetstringchar -> print_string "string.unsafe_get" + | Psetstringchar -> print_string "string.unsafe_set" + | Psafegetstringchar -> print_string "string.get" + | Psafesetstringchar -> print_string "string.set" | Pvectlength -> print_string "array.length" - | Pgetvectitem -> print_string "array.get" - | Psetvectitem -> print_string "array.set" + | Pgetvectitem -> print_string "array.unsafe_get" + | Psetvectitem _ -> print_string "array.unsafe_set" + | Psafegetvectitem -> print_string "array.get" + | Psafesetvectitem _ -> print_string "array.set" | Ptranslate tbl -> print_string "translate ["; open_hvbox 0; diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 95e56f7b1..f58020dfc 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -87,24 +87,42 @@ and bind_patterns env patl argl = let comparisons_table = create_hashtable 11 [ "%equal", - (Pccall("equal", 2), Pintcomp Ceq, Pfloatcomp Ceq); + (Pccall("equal", 2, true), + Pintcomp Ceq, + Pfloatcomp Ceq, + Pccall("string_equal", 2, false)); "%notequal", - (Pccall("notequal", 2), Pintcomp Cneq, Pfloatcomp Cneq); + (Pccall("notequal", 2, true), + Pintcomp Cneq, + Pfloatcomp Cneq, + Pccall("string_notequal", 2, false)); "%lessthan", - (Pccall("lessthan", 2), Pintcomp Clt, Pfloatcomp Clt); + (Pccall("lessthan", 2, true), + Pintcomp Clt, + Pfloatcomp Clt, + Pccall("lessthan", 2, true)); "%greaterthan", - (Pccall("greaterthan", 2), Pintcomp Cgt, Pfloatcomp Cgt); + (Pccall("greaterthan", 2, true), + Pintcomp Cgt, + Pfloatcomp Cgt, + Pccall("greaterthan", 2, true)); "%lessequal", - (Pccall("lessequal", 2), Pintcomp Cle, Pfloatcomp Cle); + (Pccall("lessequal", 2, true), + Pintcomp Cle, + Pfloatcomp Cle, + Pccall("lessequal", 2, true)); "%greaterequal", - (Pccall("greaterequal", 2), Pintcomp Cge, Pfloatcomp Cge) + (Pccall("greaterequal", 2, true), + Pintcomp Cge, + Pfloatcomp Cge, + Pccall("greaterequal", 2, true)) ] let primitives_table = create_hashtable 31 [ "%identity", Pidentity; "%field0", Pfield 0; "%field1", Pfield 1; - "%setfield0", Psetfield 0; + "%setfield0", Psetfield(0, true); "%makeblock", Pmakeblock 0; "%raise", Praise; "%sequand", Psequand; @@ -143,11 +161,16 @@ let primitives_table = create_hashtable 31 [ "%lefloat", Pfloatcomp Cle; "%gtfloat", Pfloatcomp Cgt; "%gefloat", Pfloatcomp Cge; + "%string_length", Pstringlength; + "%string_safe_get", Psafegetstringchar; + "%string_safe_set", Psafesetstringchar; "%string_unsafe_get", Pgetstringchar; "%string_unsafe_set", Psetstringchar; "%array_length", Pvectlength; + "%array_safe_get", Psafegetvectitem; + "%array_safe_set", Psafesetvectitem true; "%array_unsafe_get", Pgetvectitem; - "%array_unsafe_set", Psetvectitem + "%array_unsafe_set", Psetvectitem true ] let same_base_type ty1 ty2 = @@ -155,9 +178,15 @@ let same_base_type ty1 ty2 = (Tconstr(p1, []), Tconstr(p2, [])) -> Path.same p1 p2 | (_, _) -> false +let maybe_pointer arg = + if same_base_type arg.exp_type Predef.type_int + or same_base_type arg.exp_type Predef.type_char + then false + else true + let transl_prim prim arity args = try - let (gencomp, intcomp, floatcomp) = + let (gencomp, intcomp, floatcomp, stringcomp) = Hashtbl.find comparisons_table prim in match args with [arg1; arg2] when same_base_type arg1.exp_type Predef.type_int @@ -165,13 +194,24 @@ let transl_prim prim arity args = intcomp | [arg1; arg2] when same_base_type arg1.exp_type Predef.type_float -> floatcomp + | [arg1; arg2] when same_base_type arg1.exp_type Predef.type_string -> + stringcomp | _ -> gencomp with Not_found -> try - Hashtbl.find primitives_table prim + let p = Hashtbl.find primitives_table prim in + begin match (p, args) with + (Psetfield(n, _), [arg1; arg2]) -> + Psetfield(n, maybe_pointer arg2) + | (Psafesetvectitem _, [arg1; arg2; arg3]) -> + Psafesetvectitem(maybe_pointer arg3) + | (Psetvectitem _, [arg1; arg2; arg3]) -> + Psetvectitem(maybe_pointer arg3) + | _ -> p + end with Not_found -> - Pccall(prim, arity) + Pccall(prim, arity, true) (* To check the well-formedness of r.h.s. of "let rec" definitions *) @@ -284,7 +324,7 @@ let rec transl_exp env e = | Texp_field(arg, lbl) -> Lprim(Pfield lbl.lbl_pos, [transl_exp env arg]) | Texp_setfield(arg, lbl, newval) -> - Lprim(Psetfield lbl.lbl_pos, + Lprim(Psetfield(lbl.lbl_pos, maybe_pointer newval), [transl_exp env arg; transl_exp env newval]) | Texp_array expr_list -> Lprim(Pmakeblock 0, transl_list env expr_list) @@ -351,14 +391,14 @@ let transl_primitive = function | Primitive(name, arity) -> let prim = try - let (gencomp, intcomp, floatcomp) = + let (gencomp, intcomp, floatcomp, stringcomp) = Hashtbl.find comparisons_table name in gencomp with Not_found -> try Hashtbl.find primitives_table name with Not_found -> - Pccall(name, arity) in + Pccall(name, arity, true) in let rec add_params n params = if n >= arity then Lprim(prim, List.rev params) diff --git a/byterun/alloc.c b/byterun/alloc.c index 5c27d88ff..37d9ce710 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -92,23 +92,20 @@ value alloc_array(funct, arr) nbr = 0; while (arr[nbr] != 0) nbr++; if (nbr == 0) { - v = Atom(0); + return Atom(0); } else { - while (extern_sp - nbr <= stack_low) - realloc_stack(); + Push_roots(r, 1); + r[0] = nbr < Max_young_wosize ? alloc(nbr, 0) : alloc_shr(nbr, 0); for (n = 0; n < nbr; n++) - *--extern_sp = funct(arr[n]); - if (nbr < Max_young_wosize) { - v = alloc(nbr, 0); - n = nbr; - while (n-- > 0) Field (v, n) = *extern_sp++; - } else { - v = alloc_shr(nbr, 0); - n = nbr; - while (n-- > 0) initialize (&Field(v, n), *extern_sp++); + Field(r[0], n) = Val_int(0); + for (n = 0; n < nbr; n++) { + v = funct(arr[n]); + modify(&Field(r[0], n), v); } + v = r[0]; + Pop_roots(); + return v; } - return v; } value copy_string_array(arr) diff --git a/byterun/compare.c b/byterun/compare.c index 3cf66ba5f..e3416877e 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -17,9 +17,11 @@ static long compare_val(v1, v2) if (Is_long(v1) || Is_long(v2)) return Long_val(v1) - Long_val(v2); /* If one of the objects is outside the heap (but is not an atom), use address comparison. */ - if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap(v1)) || - (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap(v2))) - return v1 - v2; + /* Does not work with the native-code generator ! + Removed, but need to find something */ + /* if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap(v1)) || + (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap(v2))) + return v1 - v2; */ t1 = Tag_val(v1); t2 = Tag_val(v2); if (t1 != t2) return (long)t1 - (long)t2; @@ -46,6 +48,7 @@ static long compare_val(v1, v2) case Final_tag: invalid_argument("equal: abstract value"); case Closure_tag: + case Infix_tag: invalid_argument("equal: functional value"); default: { mlsize_t sz1 = Wosize_val(v1); diff --git a/byterun/extern.c b/byterun/extern.c index ea05d35e7..4be22d62a 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -190,6 +190,7 @@ static void emit_compact(chan, v) invalid_argument("output_value: abstract value"); break; case Closure_tag: + case Infix_tag: invalid_argument("output_value: functional value"); break; default: { diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 0c2f167f6..c81530666 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -86,7 +86,7 @@ value gc_stat(v) /* ML */ res = alloc (13, 0); Field (res, 0) = Val_long (stat_minor_words - + Wsize_bsize (young_ptr - young_start)); + + Wsize_bsize (young_end - young_ptr)); Field (res, 1) = Val_long (stat_promoted_words); Field (res, 2) = Val_long (stat_major_words + allocated_words); Field (res, 3) = Val_long (stat_minor_collections); diff --git a/byterun/hash.c b/byterun/hash.c index 4884cc96d..5004ce6f7 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -74,6 +74,9 @@ static void hash_aux(obj) /* We don't know anything about the contents of the block. Better do nothing. */ break; + case Infix_tag: + hash_aux(obj - Infix_offset_val(obj)); + break; default: hash_univ_count--; Combine_small(tag); diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 11dd32b79..15207e436 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -65,26 +65,20 @@ static void realloc_gray_vals () void darken (v) value v; { - if (Is_block (v) && Is_in_heap (v) && Is_white_val (v)){ - Hd_val (v) = Grayhd_hd (Hd_val (v)); - *gray_vals_cur++ = v; - if (gray_vals_cur >= gray_vals_end) realloc_gray_vals (); + if (Is_block (v) && Is_in_heap (v)) { + if (Tag_val(v) == Infix_tag) v -= Infix_offset_val(v); + if (Is_white_val (v)){ + Hd_val (v) = Grayhd_hd (Hd_val (v)); + *gray_vals_cur++ = v; + if (gray_vals_cur >= gray_vals_end) realloc_gray_vals (); + } } } -static void darken_root (p, v) - value *p; - value v; -{ - darken (v); -} - static void start_cycle () { Assert (gray_vals_cur == gray_vals); - Assert (Is_white_val (global_data)); - darken (global_data); - scan_local_roots (darken_root); + darken_all_roots(); gc_phase = Phase_mark; markhp = NULL; } diff --git a/byterun/memory.h b/byterun/memory.h index 5df199e02..35534feec 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -21,17 +21,15 @@ char * stat_resize P((char *, asize_t)); /* Size in bytes. */ #define Alloc_small(result, wosize, tag) { \ - char *_res_ = young_ptr; \ - young_ptr += Bhsize_wosize (wosize); \ - if (young_ptr > young_end){ \ + young_ptr -= Bhsize_wosize (wosize); \ + if (young_ptr < young_start){ \ Setup_for_gc; \ minor_collection (); \ Restore_after_gc; \ - _res_ = young_ptr; \ - young_ptr += Bhsize_wosize (wosize); \ + young_ptr -= Bhsize_wosize (wosize); \ } \ - Hd_hp (_res_) = Make_header ((wosize), (tag), Black); \ - (result) = Val_hp (_res_); \ + Hd_hp (young_ptr) = Make_header ((wosize), (tag), Black); \ + (result) = Val_hp (young_ptr); \ } /* You must use [Modify] to change a field of an existing shared block, diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index f2fd8fbd3..2ee3359a9 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -11,7 +11,7 @@ #include "roots.h" asize_t minor_heap_size; -char *young_start = NULL, *young_end, *young_ptr = NULL; +char *young_start = NULL, *young_end = NULL, *young_ptr = NULL; static value **ref_table = NULL, **ref_table_end, **ref_table_threshold; value **ref_table_ptr = NULL, **ref_table_limit; static asize_t ref_table_size, ref_table_reserve; @@ -25,15 +25,15 @@ void set_minor_heap_size (size) Assert (size >= Minor_heap_min); Assert (size <= Minor_heap_max); Assert (size % sizeof (value) == 0); - if (young_ptr != young_start) minor_collection (); - Assert (young_ptr == young_start); + if (young_ptr != young_end) minor_collection (); + Assert (young_ptr == young_end); new_heap = (char *) stat_alloc (size); if (young_start != NULL){ stat_free ((char *) young_start); } young_start = new_heap; young_end = new_heap + size; - young_ptr = young_start; + young_ptr = young_end; minor_heap_size = size; ref_table_size = minor_heap_size / sizeof (value) / 8; @@ -48,7 +48,7 @@ void set_minor_heap_size (size) ref_table_end = ref_table + ref_table_size + ref_table_reserve; } -static void oldify (p, v) +void oldify (p, v) value *p; value v; { @@ -57,9 +57,13 @@ static void oldify (p, v) tail_call: if (Is_block (v) && Is_young (v)){ - Assert (Hp_val (v) < young_ptr); + Assert (Hp_val (v) >= young_ptr); if (Is_blue_val (v)){ /* Already forwarded ? */ *p = Field (v, 0); /* Then the forward pointer is the first field. */ + }else if (Tag_val(v) == Infix_tag) { + mlsize_t offset = Infix_offset_val(v); + oldify(p, v - offset); + *p += offset; }else if (Tag_val (v) >= No_scan_tag){ result = alloc_shr (Wosize_val (v), Tag_val (v)); bcopy (Bp_val (v), Bp_val (result), Bosize_val (v)); @@ -109,10 +113,10 @@ void minor_collection () external_raise = &raise_buf; gc_message ("<", 0); - scan_local_roots (oldify); + oldify_local_roots(); for (r = ref_table; r < ref_table_ptr; r++) oldify (*r, **r); - stat_minor_words += Wsize_bsize (young_ptr - young_start); - young_ptr = young_start; + stat_minor_words += Wsize_bsize (young_end - young_ptr); + young_ptr = young_end; ref_table_ptr = ref_table; ref_table_limit = ref_table_threshold; gc_message (">", 0); diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h index 112ba58a9..11f9baf1c 100644 --- a/byterun/minor_gc.h +++ b/byterun/minor_gc.h @@ -14,6 +14,6 @@ extern asize_t minor_heap_size; extern void set_minor_heap_size P((asize_t)); extern void minor_collection P((void)); extern void realloc_ref_table P((void)); - +extern void oldify P((value *, value)); #endif /* _minor_gc_ */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index b50730734..38397569d 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -131,8 +131,8 @@ bits 63 10 9 8 7 0 /* Also an l-value. */ #endif -/* The Lowest tag for blocks containing no value. */ -#define No_scan_tag (Num_tags - 4) +/* The lowest tag for blocks containing no value. */ +#define No_scan_tag (Num_tags - 5) /* 1- If tag < No_scan_tag : a tuple of fields. */ @@ -148,8 +148,14 @@ typedef opcode_t * code_t; #define Closure_tag (No_scan_tag - 1) #define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */ +/* 2- If tag == No_scan_tag : an infix header inside a closure */ +/* Since No_scan_tag is odd, the infix header will be scanned as an integer */ -/* 2- If tag >= No_scan_tag : a sequence of bytes. */ +#define Infix_tag No_scan_tag +#define Infix_offset_hd(hd) (Bosize_hd(hd)) +#define Infix_offset_val(v) Infix_offset_hd(Hd_val(v)) + +/* 2- If tag > No_scan_tag : a sequence of bytes. */ /* Pointer to the first byte */ #define Bp_val(v) ((char *) (v)) @@ -161,14 +167,14 @@ typedef opcode_t * code_t; /* Abstract things. Their contents is not traced by the GC; therefore they must not contain any [value]. */ -#define Abstract_tag No_scan_tag +#define Abstract_tag (No_scan_tag + 1) /* Strings. */ -#define String_tag (No_scan_tag + 1) +#define String_tag (No_scan_tag + 2) #define String_val(x) ((char *) Bp_val(x)) /* Floating-point numbers. */ -#define Double_tag (No_scan_tag + 2) +#define Double_tag (No_scan_tag + 3) #define Double_wosize ((sizeof(double) / sizeof(value))) #ifndef ALIGN_DOUBLE #define Double_val(v) (* (double *) (v)) @@ -181,7 +187,7 @@ void Store_double_val P((value,double)); /* Finalized things. Just like abstract things, but the GC will call the [Final_fun] before deallocation. */ -#define Final_tag (No_scan_tag + 3) +#define Final_tag (No_scan_tag + 4) typedef void (*final_fun) P((value)); #define Final_fun(val) (((final_fun *) (val)) [0]) /* Also an l-value. */ @@ -198,6 +204,7 @@ extern header_t first_atoms[]; #define Bool_val(x) Int_val(x) #define Val_false Val_int(0) #define Val_true Val_int(1) +#define Val_not(x) (4 - (x)) /* The unit value is 0 */ diff --git a/byterun/roots.c b/byterun/roots.c index eb0f5dfd0..0a3f780fa 100644 --- a/byterun/roots.c +++ b/byterun/roots.c @@ -1,6 +1,8 @@ /* To walk the memory roots for garbage collection */ #include "memory.h" +#include "major_gc.h" +#include "minor_gc.h" #include "misc.h" #include "mlvalues.h" #include "roots.h" @@ -15,8 +17,21 @@ struct global_root { static struct global_root * global_roots = NULL; -void scan_local_roots (copy_fn) - void (*copy_fn) (); +/* Register a global C root */ + +void register_global_root(r) + value * r; +{ + struct global_root * gr; + gr = (struct global_root *) stat_alloc(sizeof(struct global_root)); + gr->root = r; + gr->next = global_roots; + global_roots = gr; +} + +/* Call [oldify] on all stack roots and C roots */ + +void oldify_local_roots () { register value * sp; value * block; @@ -24,26 +39,46 @@ void scan_local_roots (copy_fn) /* The stack */ for (sp = extern_sp; sp < stack_high; sp++) { - copy_fn (sp, *sp); + oldify (sp, *sp); } /* Local C roots */ for (block = local_roots; block != NULL; block = (value *) block [1]){ for (sp = block - (long) block [0]; sp < block; sp++){ - copy_fn (sp, *sp); + oldify (sp, *sp); } } /* Global C roots */ for (gr = global_roots; gr != NULL; gr = gr->next) { - copy_fn(gr->root, *(gr->root)); + oldify(gr->root, *(gr->root)); } } -void register_global_root(r) - value * r; +/* Call [darken] on all roots */ + +void darken_all_roots () { + register value * sp; + value * block; struct global_root * gr; - gr = (struct global_root *) stat_alloc(sizeof(struct global_root)); - gr->root = r; - gr->next = global_roots; - global_roots = gr; + + /* Global variables */ + darken(global_data); + + /* The stack */ + for (sp = extern_sp; sp < stack_high; sp++) { + darken (*sp); + } + /* Local C roots */ + for (block = local_roots; block != NULL; block = (value *) block [1]){ + for (sp = block - (long) block [0]; sp < block; sp++){ + darken (*sp); + } + } + /* Global C roots */ + for (gr = global_roots; gr != NULL; gr = gr->next) { + darken (*(gr->root)); + } } + + + diff --git a/byterun/roots.h b/byterun/roots.h index 67732f3cb..5f5ff5b84 100644 --- a/byterun/roots.h +++ b/byterun/roots.h @@ -3,7 +3,8 @@ #include "misc.h" -void scan_local_roots P((void (*copy_fn) (value *, value))); +void oldify_local_roots P((void)); +void darken_all_roots P((void)); #endif /* _roots_ */ diff --git a/byterun/str.c b/byterun/str.c index 5e1ad99b8..a97a8d787 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -49,6 +49,24 @@ value string_set(str, index, newval) /* ML */ return Val_unit; } +value string_equal(s1, s2) /* ML */ + value s1, s2; +{ + mlsize_t sz1 = Wosize_val(s1); + mlsize_t sz2 = Wosize_val(s2); + value * p1, * p2; + if (sz1 != sz2) return Val_false; + for(p1 = Op_val(s1), p2 = Op_val(s2); sz1 > 0; sz1--, p1++, p2++) + if (*p1 != *p2) return Val_false; + return Val_true; +} + +value string_notequal(s1, s2) /* ML */ + value s1, s2; +{ + return Val_not(string_equal(s1, s2)); +} + value blit_string(argv, argc) /* ML */ value * argv; int argc; diff --git a/driver/optmain.ml b/driver/optmain.ml index 12da49eb3..1a02f99a0 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -52,6 +52,7 @@ let main () = "-dalloc", Arg.Unit(fun () -> Clflags.dump_regalloc := true); "-dreload", Arg.Unit(fun () -> Clflags.dump_reload := true); "-dlinear", Arg.Unit(fun () -> Clflags.dump_linear := true); + "-dstartup", Arg.Unit(fun () -> Clflags.keep_startup_file := true); "-v", Arg.Unit print_version_number; "-", Arg.String process_file] process_file; diff --git a/stdlib/.depend b/stdlib/.depend index a22557655..b1ae6b0c6 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -1,26 +1,45 @@ format.cmi: list.cmi -gc.cmi: lexing.cmi: obj.cmi parsing.cmi: lexing.cmi obj.cmi -printexc.cmi: arg.cmo: arg.cmi sys.cmi string.cmi list.cmi array.cmi printf.cmi -array.cmo: array.cmi list.cmi array.cmi -char.cmo: char.cmi char.cmi string.cmi +arg.cmx: arg.cmi sys.cmx string.cmx list.cmx array.cmx printf.cmx +array.cmo: array.cmi list.cmi +array.cmx: array.cmi list.cmx +char.cmo: char.cmi string.cmi +char.cmx: char.cmi string.cmx filename.cmo: filename.cmi string.cmi +filename.cmx: filename.cmi string.cmx format.cmo: format.cmi queue.cmi string.cmi list.cmi +format.cmx: format.cmi queue.cmx string.cmx list.cmx gc.cmo: gc.cmi printf.cmi +gc.cmx: gc.cmi printf.cmx hashtbl.cmo: hashtbl.cmi array.cmi +hashtbl.cmx: hashtbl.cmi array.cmx lexing.cmo: lexing.cmi string.cmi obj.cmi -list.cmo: list.cmi list.cmi -map.cmo: map.cmi +lexing.cmx: lexing.cmi string.cmx obj.cmx +list.cmo: list.cmi +list.cmx: list.cmi +map.cmo: map.cmi set.cmi +map.cmx: map.cmi set.cmx obj.cmo: obj.cmi +obj.cmx: obj.cmi parsing.cmo: parsing.cmi array.cmi lexing.cmi obj.cmi +parsing.cmx: parsing.cmi array.cmx lexing.cmx obj.cmx pervasives.cmo: pervasives.cmi +pervasives.cmx: pervasives.cmi printexc.cmo: printexc.cmi obj.cmi +printexc.cmx: printexc.cmi obj.cmx printf.cmo: printf.cmi string.cmi list.cmi obj.cmi +printf.cmx: printf.cmi string.cmx list.cmx obj.cmx queue.cmo: queue.cmi +queue.cmx: queue.cmi set.cmo: set.cmi +set.cmx: set.cmi sort.cmo: sort.cmi +sort.cmx: sort.cmi stack.cmo: stack.cmi list.cmi -string.cmo: string.cmi char.cmi string.cmi list.cmi +stack.cmx: stack.cmi list.cmx +string.cmo: string.cmi list.cmi +string.cmx: string.cmi list.cmx sys.cmo: sys.cmi +sys.cmx: sys.cmi diff --git a/stdlib/Makefile b/stdlib/Makefile index b01545fcc..34ee1df97 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -3,6 +3,8 @@ include ../Makefile.config RUNTIME=../boot/camlrun COMPILER=../camlc CAMLC=$(RUNTIME) $(COMPILER) +OPTCOMPILER=../camlopt +CAMLOPT=$(RUNTIME) $(OPTCOMPILER) CAMLDEP=../tools/camldep OBJS=pervasives.cmo list.cmo string.cmo char.cmo array.cmo sys.cmo \ @@ -18,6 +20,10 @@ install: stdlib.cma: $(OBJS) $(CAMLC) -a -o stdlib.cma $(OBJS) +# stdlib.cmxa: $(OBJS:.cmo=.cmx) +# $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx) +optlib: $(OBJS:.cmo=.cmx) + cslheader: header.c ../Makefile.config if $(SHARPBANGSCRIPTS); \ then echo "#!$(BINDIR)/cslrun" > cslheader; \ @@ -30,7 +36,10 @@ pervasives.cmi: pervasives.mli pervasives.cmo: pervasives.ml $(CAMLC) -nopervasives -c pervasives.ml -.SUFFIXES: .mli .ml .cmi .cmo +pervasives.cmx: pervasives.ml + $(CAMLOPT) -nopervasives -c pervasives.ml + +.SUFFIXES: .mli .ml .cmi .cmo .cmx .mli.cmi: $(CAMLC) $(COMPFLAGS) -c $< @@ -38,13 +47,17 @@ pervasives.cmo: pervasives.ml .ml.cmo: $(CAMLC) $(COMPFLAGS) -c $< +.ml.cmx: + $(CAMLOPT) $(COMPFLAGS) -c $< + $(OBJS): pervasives.cmi $(OBJS): $(COMPILER) $(OBJS:.cmo=.cmi): $(COMPILER) +$(OBJS:.cmo=.cmx): $(OPTCOMPILER) clean: - rm -f *.cm[ioa] + rm -f *.cm* rm -f cslheader rm -f *~ diff --git a/stdlib/array.ml b/stdlib/array.ml index d539d76c6..62c475d22 100644 --- a/stdlib/array.ml +++ b/stdlib/array.ml @@ -1,23 +1,11 @@ (* Array operations *) external length : 'a array -> int = "%array_length" +external get: 'a array -> int -> 'a = "%array_safe_get" +external set: 'a array -> int -> 'a -> unit = "%array_safe_set" external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get" external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set" external new: int -> 'a -> 'a array = "make_vect" -external get: 'a array -> int -> 'a = "array_get" -external set: 'a array -> int -> 'a -> unit = "array_set" - -(***** -let get a n = - if n < 0 or n >= length a - then invalid_arg "Array.get" - else unsafe_get a n - -let set a n v = - if n < 0 or n >= length a - then invalid_arg "Array.set" - else unsafe_set a n v -*****) let new_matrix sx sy init = let res = new sx [||] in diff --git a/stdlib/array.mli b/stdlib/array.mli index e0d9983d7..04968bce9 100644 --- a/stdlib/array.mli +++ b/stdlib/array.mli @@ -1,9 +1,8 @@ (* Array operations *) external length : 'a array -> int = "%array_length" - -external get: 'a array -> int -> 'a = "array_get" -external set: 'a array -> int -> 'a -> unit = "array_set" +external get: 'a array -> int -> 'a = "%array_safe_get" +external set: 'a array -> int -> 'a -> unit = "%array_safe_set" external new: int -> 'a -> 'a array = "make_vect" val new_matrix: int -> int -> 'a -> 'a array array val append: 'a array -> 'a array -> 'a array diff --git a/stdlib/string.ml b/stdlib/string.ml index d26ff55a5..77ed8a7bb 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -1,27 +1,15 @@ (* String operations *) -external length : string -> int = "ml_string_length" +external length : string -> int = "%string_length" +external get : string -> int -> char = "%string_safe_get" +external set : string -> int -> char -> unit = "%string_safe_set" external create: int -> string = "create_string" external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" -external get : string -> int -> char = "string_get" -external set : string -> int -> char -> unit = "string_set" external unsafe_blit : string -> int -> string -> int -> int -> unit = "blit_string" external unsafe_fill : string -> int -> int -> char -> unit = "fill_string" -(****** -let get s n = - if n < 0 or n >= length s - then invalid_arg "String.get" - else unsafe_get s n - -let set s n c = - if n < 0 or n >= length s - then invalid_arg "String.set" - else unsafe_set s n c -*******) - let make n c = let s = create n in unsafe_fill s 0 n c; @@ -72,6 +60,8 @@ let concat sep l = r external is_printable: char -> bool = "is_printable" +external char_code: char -> int = "%identity" +external char_chr: int -> char = "%identity" let escaped s = let n = ref 0 in @@ -97,14 +87,14 @@ let escaped s = if is_printable c then unsafe_set s' !n c else begin - let a = Char.code c in + let a = char_code c in unsafe_set s' !n '\\'; incr n; - unsafe_set s' !n (Char.unsafe_chr (48 + a / 100)); + unsafe_set s' !n (char_chr (48 + a / 100)); incr n; - unsafe_set s' !n (Char.unsafe_chr (48 + (a / 10) mod 10)); + unsafe_set s' !n (char_chr (48 + (a / 10) mod 10)); incr n; - unsafe_set s' !n (Char.unsafe_chr (48 + a mod 10)) + unsafe_set s' !n (char_chr (48 + a mod 10)) end end; incr n diff --git a/stdlib/string.mli b/stdlib/string.mli index ddf2df1bd..fa1c35c4e 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -1,9 +1,9 @@ (* String operations *) -external length : string -> int = "ml_string_length" +external length : string -> int = "%string_length" -external get : string -> int -> char = "string_get" -external set : string -> int -> char -> unit = "string_set" +external get : string -> int -> char = "%string_safe_get" +external set : string -> int -> char -> unit = "%string_safe_set" external create : int -> string = "create_string" val make : int -> char -> string diff --git a/testasmcomp/Makefile b/testasmcomp/Makefile index f4e707304..4034752dc 100644 --- a/testasmcomp/Makefile +++ b/testasmcomp/Makefile @@ -1,5 +1,3 @@ -ARCH=alpha - include ../Makefile.config CAMLC=../boot/camlrun ../boot/camlc -I ../boot diff --git a/testasmcomp/parsecmm.mly b/testasmcomp/parsecmm.mly index a20a0c6bb..82c70b8ff 100644 --- a/testasmcomp/parsecmm.mly +++ b/testasmcomp/parsecmm.mly @@ -164,7 +164,7 @@ expr: | LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_ident $3, $4) } | LBRACKET exprlist RBRACKET { Ctuple(List.rev $2) } | LPAREN APPLY expr expr machtype RPAREN { Cop(Capply $5, [$3; $4]) } - | LPAREN EXTCALL STRING expr machtype RPAREN { Cop(Cextcall($3, $5), [$4]) } + | LPAREN EXTCALL STRING expr machtype RPAREN { Cop(Cextcall($3, $5, true), [$4]) } | LPAREN LOAD expr machtype RPAREN { Cop(Cload $4, [$3]) } | LPAREN unaryop expr RPAREN { Cop($2, [$3]) } | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4]) } diff --git a/tools/camldep b/tools/camldep index 8f5325797..905f208e8 100755 --- a/tools/camldep +++ b/tools/camldep @@ -27,7 +27,7 @@ sub scan_source { local ($source_name, $target_name) = @_; $modname = $target_name; $modname =~ s|^.*/||; - $modname =~ s|\.z[io]$||; + $modname =~ s|\.cm[iox]$||; undef(%imports); open(SRC, $source_name) || return; while(<SRC>) { @@ -41,8 +41,10 @@ sub scan_source { } close(SRC); undef(@deps); + undef(@optdeps); if ($target_name =~ m/(.*)\.cmo$/ && -r ($source_name . "i")) { push(@deps, "$1.cmi"); + push(@optdeps, "$1.cmi"); } foreach $modl (keys(%imports)) { $modl = do lowercase($modl); @@ -50,26 +52,38 @@ sub scan_source { if ($dep = do find_path ("$modl.mli")) { $dep =~ s/\.mli$/.cmi/; push(@deps, $dep); + $dep =~ s/\.cmi$/.cmx/; + push(@optdeps, $dep); } elsif ($dep = do find_path ("$modl.ml")) { $dep =~ s/\.ml$/.cmo/; push(@deps, $dep); + $dep =~ s/\.cmo$/.cmx/; + push(@optdeps, $dep); } } if ($#deps >= 0) { print "$target_name: "; - $col = length($target_name) + 2; - foreach $dep (@deps) { - next if $dep eq $target_name; - $col += length($dep) + 1; - if ($col >= 77) { - print "\\\n "; - $col = length($dep) + 5; - } - print $dep, " "; + do print_deps(@deps); + } + if ($target_name =~ /^(.*)\.cmo$/ && $#optdeps >= 0) { + print "$1.cmx: "; + do print_deps(@optdeps); + } +} + +sub print_deps { + $col = length($target_name) + 3; + foreach $dep (@_) { + next if $dep eq $target_name; + $col += length($dep) + 1; + if ($col >= 77) { + print "\\\n "; + $col = length($dep) + 5; } - print "\n"; + print $dep, " "; } + print "\n"; } sub find_path { diff --git a/utils/clflags.ml b/utils/clflags.ml index 477e16196..17c99b1c4 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -30,3 +30,4 @@ let dump_prefer = ref false (* -dprefer *) let dump_regalloc = ref false (* -dalloc *) let dump_reload = ref false (* -dreload *) let dump_linear = ref false (* -dlinear *) +let keep_startup_file = ref false (* -dstartup *) diff --git a/utils/config.mlp b/utils/config.mlp index 3b9389e01..175f6f525 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -15,4 +15,4 @@ and cmxa_magic_number = "Caml1999Z001" let load_path = ref ([] : string list) -let max_tag = 251 +let max_tag = 249 |