Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Reintegrate raise_variants branch. 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14289 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-11-13 13:55:13 +00:00
parent 37b6979939 a51080b15a
commit f16534ef1a
78 changed files with 416 additions and 279 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
asmcomp/amd64/emit.mlp
View File

@ -713,11 +713,16 @@ let emit_instr fallthrough i =
` addq $8, %rsp\n`;
cfi_adjust_cfa_offset (-8);
stack_offset := !stack_offset - 16
| Lraise ->
if !Clflags.debug then begin
| Lraise k ->
begin match !Clflags.debug, k with
| true, Lambda.Raise_regular ->
` {emit_call "caml_raise_exn"}\n`;
record_frame Reg.Set.empty i.dbg
end else begin
| true, Lambda.Raise_reraise ->
` {emit_call "caml_reraise_exn"}\n`;
record_frame Reg.Set.empty i.dbg
| false, _
| true, Lambda.Raise_notrace ->
` movq %r14, %rsp\n`;
` popq %r14\n`;
` ret\n`

12
asmcomp/amd64/emit_nt.mlp
View File

@ -710,11 +710,16 @@ let emit_instr fallthrough i =
` pop r14\n`;
` add rsp, 8\n`;
stack_offset := !stack_offset - 16
| Lraise ->
if !Clflags.debug then begin
| Lraise k ->
begin match !Clflags.debug, k with
| true, Lambda.Raise_regular ->
` call caml_raise_exn\n`;
record_frame Reg.Set.empty i.dbg
end else begin
| true, Lambda.Raise_reraise ->
` call caml_reraise_exn\n`;
record_frame Reg.Set.empty i.dbg
| false, _
| true, Lambda.Raise_notrace ->
` mov rsp, r14\n`;
` pop r14\n`;
` ret\n`
@ -806,6 +811,7 @@ let begin_assembly() =
` EXTRN caml_alloc3: NEAR\n`;
` EXTRN caml_ml_array_bound_error: NEAR\n`;
` EXTRN caml_raise_exn: NEAR\n`;
` EXTRN caml_reraise_exn: NEAR\n`;
let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
add_def_symbol lbl_begin;
` .DATA\n`;

8
asmcomp/arm/emit.mlp
View File

@ -855,11 +855,13 @@ let emit_instr i =
` pop \{trap_ptr, lr}\n`;
cfi_adjust_cfa_offset (-8);
stack_offset := !stack_offset - 8; 1
| Lraise ->
if !Clflags.debug then begin
| Lraise k ->
begin match !Clflags.debug, k with
| true, (Lambda.Raise_regular | Lambda.Raise_reraise) ->
` {emit_call "caml_raise_exn"}\n`;
`{record_frame Reg.Set.empty i.dbg}\n`; 1
end else begin
| false, _
| true, Lambda.Raise_notrace ->
` mov sp, trap_ptr\n`;
` pop \{trap_ptr, pc}\n`; 2
end

6
asmcomp/arm64/emit.mlp
View File

@ -638,10 +638,12 @@ let emit_instr i =
cfi_adjust_cfa_offset (-16);
stack_offset := !stack_offset - 16
| Lraise ->
if !Clflags.debug then begin
begin match !Clflags.debug, k with
| true, (Lambda.Raise_regular | Lambda.Raise_reraise) ->
` bl {emit_symbol "caml_raise_exn"}\n`;
`{record_frame Reg.Set.empty i.dbg}\n`
end else begin
| false, _
| true, Lambda.Raise_notrace ->
` mov sp, {emit_reg reg_trap_ptr}\n`;
` ldr {emit_reg reg_tmp1}, [sp, #8]\n`;
` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`;

4
asmcomp/asmlink.ml
View File

@ -206,8 +206,8 @@ let make_startup_file ppf filename units_list =
compile_phrase (Cmmgen.entry_point name_list);
let units = List.map (fun (info,_,_) -> info) units_list in
List.iter compile_phrase (Cmmgen.generic_functions false units);
Array.iter
(fun name -> compile_phrase (Cmmgen.predef_exception name))
Array.iteri
(fun i name -> compile_phrase (Cmmgen.predef_exception i name))
Runtimedef.builtin_exceptions;
compile_phrase (Cmmgen.global_table name_list);
compile_phrase

14
asmcomp/closure.ml
View File

@ -96,7 +96,7 @@ let prim_size prim args =
| Psetfloatfield f -> 1
| Pduprecord _ -> 10 + List.length args
| Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args
| Praise -> 4
| Praise _ -> 4
| Pstringlength -> 5
| Pstringrefs | Pstringsets -> 6
| Pmakearray kind -> 5 + List.length args
@ -180,7 +180,7 @@ let rec is_pure_clambda = function
Uvar v -> true
| Uconst _ -> true
| Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets |
Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets |
Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
| Uprim(p, args, _) -> List.for_all is_pure_clambda args
| _ -> false
@ -403,7 +403,7 @@ let rec is_pure = function
Lvar v -> true
| Lconst cst -> true
| Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets |
Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets |
Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false
| Lprim(p, args) -> List.for_all is_pure args
| Levent(lam, ev) -> is_pure lam
@ -473,8 +473,8 @@ let rec add_debug_info ev u =
args2, Debuginfo.from_call ev)
| Ugeneric_apply(fn, args, dinfo) ->
Ugeneric_apply(fn, args, Debuginfo.from_call ev)
| Uprim(Praise, args, dinfo) ->
Uprim(Praise, args, Debuginfo.from_call ev)
| Uprim(Praise k, args, dinfo) ->
Uprim(Praise k, args, Debuginfo.from_call ev)
| Uprim(p, args, dinfo) ->
Uprim(p, args, Debuginfo.from_call ev)
| Usend(kind, u1, u2, args, dinfo) ->
@ -647,9 +647,9 @@ let rec close fenv cenv = function
(!global_approx).(n) <- approx;
(Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none),
Value_unknown)
| Lprim(Praise, [Levent(arg, ev)]) ->
| Lprim(Praise k, [Levent(arg, ev)]) ->
let (ulam, approx) = close fenv cenv arg in
(Uprim(Praise, [ulam], Debuginfo.from_raise ev),
(Uprim(Praise k, [ulam], Debuginfo.from_raise ev),
Value_unknown)
| Lprim(p, args) ->
simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none

2
asmcomp/cmm.ml
View File

@ -79,7 +79,7 @@ type operation =
| Caddf | Csubf | Cmulf | Cdivf
| Cfloatofint | Cintoffloat
| Ccmpf of comparison
| Craise of Debuginfo.t
| Craise of Lambda.raise_kind * Debuginfo.t
| Ccheckbound of Debuginfo.t
type expression =

2
asmcomp/cmm.mli
View File

@ -65,7 +65,7 @@ type operation =
| Caddf | Csubf | Cmulf | Cdivf
| Cfloatofint | Cintoffloat
| Ccmpf of comparison
| Craise of Debuginfo.t
| Craise of Lambda.raise_kind * Debuginfo.t
| Ccheckbound of Debuginfo.t
type expression =

24
asmcomp/cmmgen.ml
View File

@ -199,8 +199,8 @@ let safe_divmod op c1 c2 dbg =
bind "divisor" c2 (fun c2 ->
Cifthenelse(c2,
Cop(op, [c1; c2]),
Cop(Craise dbg,
[Cconst_symbol "caml_bucket_Division_by_zero"])))
Cop(Craise (Raise_regular, dbg),
[Cconst_symbol "caml_exn_Division_by_zero"])))
(* Division or modulo on boxed integers. The overflow case min_int / -1
can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *)
@ -220,8 +220,8 @@ let safe_divmod_bi mkop mkm1 c1 c2 bi dbg =
c3
else
Cifthenelse(c2, c3,
Cop(Craise dbg,
[Cconst_symbol "caml_bucket_Division_by_zero"]))))
Cop(Craise (Raise_regular, dbg),
[Cconst_symbol "caml_exn_Division_by_zero"]))))
let safe_div_bi =
safe_divmod_bi (fun c1 c2 -> Cop(Cdivi, [c1;c2]))
@ -1306,8 +1306,8 @@ and transl_prim_1 p arg dbg =
[if n = 0 then ptr
else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
(* Exceptions *)
| Praise ->
Cop(Craise dbg, [transl arg])
| Praise k ->
Cop(Craise (k, dbg), [transl arg])
(* Integer operations *)
| Pnegint ->
Cop(Csubi, [Cconst_int 2; transl arg])
@ -2519,16 +2519,14 @@ let code_segment_table namelist =
(* Initialize a predefined exception *)
let predef_exception name =
let bucketname = "caml_bucket_" ^ name in
let predef_exception i name =
let symname = "caml_exn_" ^ name in
Cdata(Cglobal_symbol symname ::
emit_constant symname
(Const_block(0,[Const_base(Const_string (name, None))]))
[ Cglobal_symbol bucketname;
Cint(block_header 0 1);
Cdefine_symbol bucketname;
Csymbol_address symname ])
(Const_block(Obj.object_tag,
[Const_base(Const_string (name, None));
Const_base(Const_int (-i-1))
])) [])
(* Header for a plugin *)

2
asmcomp/cmmgen.mli
View File

@ -26,5 +26,5 @@ val globals_map: (string * Digest.t * Digest.t * string list) list ->
val frame_table: string list -> Cmm.phrase
val data_segment_table: string list -> Cmm.phrase
val code_segment_table: string list -> Cmm.phrase
val predef_exception: string -> Cmm.phrase
val predef_exception: int -> string -> Cmm.phrase
val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase

2
asmcomp/comballoc.ml
View File

@ -27,7 +27,7 @@ let allocated_size = function
let rec combine i allocstate =
match i.desc with
Iend | Ireturn | Iexit _ | Iraise ->
Iend | Ireturn | Iexit _ | Iraise _ ->
(i, allocated_size allocstate)
| Iop(Ialloc sz) ->
begin match allocstate with

11
asmcomp/i386/emit.mlp
View File

@ -871,11 +871,16 @@ let emit_instr fallthrough i =
` addl ${emit_int (trap_frame_size - 4)}, %esp\n`;
cfi_adjust_cfa_offset (-trap_frame_size);
stack_offset := !stack_offset - trap_frame_size
| Lraise ->
if !Clflags.debug then begin
| Lraise k ->
begin match !Clflags.debug, k with
| true, Lambda.Raise_regular ->
` call {emit_symbol "caml_raise_exn"}\n`;
record_frame Reg.Set.empty i.dbg
end else begin
| true, Lambda.Raise_reraise ->
` call {emit_symbol "caml_reraise_exn"}\n`;
record_frame Reg.Set.empty i.dbg
| false, _
| true, Lambda.Raise_notrace ->
` movl {emit_symbol "caml_exception_pointer"}, %esp\n`;
` popl {emit_symbol "caml_exception_pointer"}\n`;
if trap_frame_size > 8 then

12
asmcomp/i386/emit_nt.mlp
View File

@ -809,11 +809,16 @@ let emit_instr i =
` pop _caml_exception_pointer\n`;
` add esp, 4\n`;
stack_offset := !stack_offset - 8
| Lraise ->
if !Clflags.debug then begin
| Lraise k ->
begin match !Clflags.debug, k with
| true, Lambda.Raise_regular ->
` call _caml_raise_exn\n`;
record_frame Reg.Set.empty i.dbg
end else begin
| true, Lambda.Raise_reraise ->
` call _caml_reraise_exn\n`;
record_frame Reg.Set.empty i.dbg
| false, _
| true, Lambda.Raise_notrace ->
` mov esp, _caml_exception_pointer\n`;
` pop _caml_exception_pointer\n`;
` ret\n`
@ -901,6 +906,7 @@ let begin_assembly() =
` EXTERN _caml_alloc3: PROC\n`;
` EXTERN _caml_ml_array_bound_error: PROC\n`;
` EXTERN _caml_raise_exn: PROC\n`;
` EXTERN _caml_reraise_exn: PROC\n`;
` .DATA\n`;
let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
add_def_symbol lbl_begin;

4
asmcomp/interf.ml
View File

@ -111,7 +111,7 @@ let build_graph fundecl =
| Itrywith(body, handler) ->
add_interf_set Proc.destroyed_at_raise handler.live;
interf body; interf handler; interf i.next
| Iraise -> () in
| Iraise _ -> () in
(* Add a preference from one reg to another.
Do not add anything if the two registers conflict,
@ -182,7 +182,7 @@ let build_graph fundecl =
()
| Itrywith(body, handler) ->
prefer weight body; prefer weight handler; prefer weight i.next
| Iraise -> ()
| Iraise _ -> ()
in
interf fundecl.fun_body; prefer 8 fundecl.fun_body

8
asmcomp/linearize.ml
View File

@ -42,10 +42,10 @@ and instruction_desc =
| Lsetuptrap of label
| Lpushtrap
| Lpoptrap
| Lraise
| Lraise of Lambda.raise_kind
let has_fallthrough = function
| Lreturn | Lbranch _ | Lswitch _ | Lraise
| Lreturn | Lbranch _ | Lswitch _ | Lraise _
| Lop Itailcall_ind | Lop (Itailcall_imm _) -> false
| _ -> true
@ -257,8 +257,8 @@ let rec linear i n =
(linear body (cons_instr Lpoptrap n1))) in
cons_instr (Lsetuptrap lbl_body)
(linear handler (add_branch lbl_join n2))
| Iraise ->
copy_instr Lraise i (discard_dead_code n)
| Iraise k ->
copy_instr (Lraise k) i (discard_dead_code n)
let fundecl f =
{ fun_name = f.Mach.fun_name;

2
asmcomp/linearize.mli
View File

@ -36,7 +36,7 @@ and instruction_desc =
| Lsetuptrap of label
| Lpushtrap
| Lpoptrap
| Lraise
| Lraise of Lambda.raise_kind
val has_fallthrough : instruction_desc -> bool
val end_instr: instruction

2
asmcomp/liveness.ml
View File

@ -89,7 +89,7 @@ let rec live i finally =
live_at_raise := saved_live_at_raise;
i.live <- before_body;
before_body
| Iraise ->
| Iraise _ ->
(* i.live remains empty since no regs are live across *)
Reg.add_set_array !live_at_raise i.arg
| _ ->

4
asmcomp/mach.ml
View File

@ -71,7 +71,7 @@ and instruction_desc =
| Icatch of int * instruction * instruction
| Iexit of int
| Itrywith of instruction * instruction
| Iraise
| Iraise of Lambda.raise_kind
type fundecl =
{ fun_name: string;
@ -125,6 +125,6 @@ let rec instr_iter f i =
| Iexit _ -> ()
| Itrywith(body, handler) ->
instr_iter f body; instr_iter f handler; instr_iter f i.next
| Iraise -> ()
| Iraise _ -> ()
| _ ->
instr_iter f i.next

2
asmcomp/mach.mli
View File

@ -71,7 +71,7 @@ and instruction_desc =
| Icatch of int * instruction * instruction
| Iexit of int
| Itrywith of instruction * instruction
| Iraise
| Iraise of Lambda.raise_kind
type fundecl =
{ fun_name: string;

10
asmcomp/power/emit.mlp
View File

@ -365,7 +365,7 @@ let instr_size = function
| Lsetuptrap lbl -> 1
| Lpushtrap -> 4
| Lpoptrap -> 2
| Lraise -> 6
| Lraise _ -> 6
let label_map code =
let map = Hashtbl.create 37 in
@ -767,11 +767,13 @@ let rec emit_instr i dslot =
` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`;
` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`;
stack_offset := !stack_offset - 16
| Lraise ->
if !Clflags.debug && supports_backtraces then begin
| Lraise k ->
begin match !Clflags.debug && supports_backtraces, k with
| true, (Lambda.Raise_regular | Lambda.Raise_reraise) ->
` bl {emit_symbol "caml_raise_exn"}\n`;
record_frame Reg.Set.empty i.dbg
end else begin
| false, _
| true, Lambda.Raise_notrace ->
` {emit_string lg} {emit_gpr 0}, 0({emit_gpr 29})\n`;
` mr {emit_gpr 1}, {emit_gpr 29}\n`;
` mtlr {emit_gpr 0}\n`;

2
asmcomp/printcmm.ml
View File

@ -81,7 +81,7 @@ let operation = function
| Cfloatofint -> "floatofint"
| Cintoffloat -> "intoffloat"
| Ccmpf c -> Printf.sprintf "%sf" (comparison c)
| Craise d -> "raise" ^ Debuginfo.to_string d
| Craise (k, d) -> Lambda.raise_kind k ^ Debuginfo.to_string d
| Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d
let rec expr ppf = function

4
asmcomp/printlinear.ml
View File

@ -60,8 +60,8 @@ let instr ppf i =
fprintf ppf "push trap"
| Lpoptrap ->
fprintf ppf "pop trap"
| Lraise ->
fprintf ppf "raise %a" reg i.arg.(0)
| Lraise k ->
fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0)
end;
if not (Debuginfo.is_none i.dbg) then
fprintf ppf " %s" (Debuginfo.to_string i.dbg)

4
asmcomp/printmach.ml
View File

@ -177,8 +177,8 @@ let rec instr ppf i =
| Itrywith(body, handler) ->
fprintf ppf "@[<v 2>try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]"
instr body instr handler
| Iraise ->
fprintf ppf "raise %a" reg i.arg.(0)
| Iraise k ->
fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0)
end;
if not (Debuginfo.is_none i.dbg) then
fprintf ppf "%s" (Debuginfo.to_string i.dbg);

2
asmcomp/reloadgen.ml
View File

@ -88,7 +88,7 @@ method private reload i =
already at the correct position (e.g. on stack for some arguments).
However, something needs to be done for the function pointer in
indirect calls. *)
Iend | Ireturn | Iop(Itailcall_imm _) | Iraise -> i
Iend | Ireturn | Iop(Itailcall_imm _) | Iraise _ -> i
| Iop(Itailcall_ind) ->
let newarg = self#makereg1 i.arg in
insert_moves i.arg newarg

6
asmcomp/selectgen.ml
View File

@ -153,7 +153,7 @@ let join_array rs =
let debuginfo_op = function
| Capply(_, dbg) -> dbg
| Cextcall(_, _, _, dbg) -> dbg
| Craise dbg -> dbg
| Craise (_, dbg) -> dbg
| Ccheckbound dbg -> dbg
| _ -> Debuginfo.none
@ -441,13 +441,13 @@ method emit_expr env exp =
| Some(simple_list, ext_env) ->
Some(self#emit_tuple ext_env simple_list)
end
| Cop(Craise dbg, [arg]) ->
| Cop(Craise (k, dbg), [arg]) ->
begin match self#emit_expr env arg with
None -> None
| Some r1 ->
let rd = [|Proc.loc_exn_bucket|] in
self#insert (Iop Imove) r1 rd;
self#insert_debug Iraise dbg rd [||];
self#insert_debug (Iraise k) dbg rd [||];
None
end
| Cop(Ccmpf comp, args) ->

2
asmcomp/sparc/emit.mlp
View File

@ -603,7 +603,7 @@ let rec emit_instr i dslot =
` ld [%sp + 100], %l5\n`;
` add %sp, 8, %sp\n`;
stack_offset := !stack_offset - 8
| Lraise ->
| Lraise _ ->
` ld [%l5 + 96], %g1\n`;
` mov %l5, %sp\n`;
` ld [%sp + 100], %l5\n`;

4
asmcomp/spill.ml
View File

@ -238,7 +238,7 @@ let rec reload i before =
reload i.next (Reg.Set.union after_body after_handler) in
(instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next,
finally)
| Iraise ->
| Iraise _ ->
(add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty)
(* Second pass: add spill instructions based on what we've decided to reload.
@ -379,7 +379,7 @@ let rec spill i finally =
spill_at_raise := saved_spill_at_raise;
(instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next,
before_body)
| Iraise ->
| Iraise _ ->
(i, !spill_at_raise)
(* Entry point *)

4
asmcomp/split.ml
View File

@ -184,8 +184,8 @@ let rec rename i sub =
rename i.next (merge_substs sub_body sub_handler i.next) in
(instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next,
sub_next)
| Iraise ->
(instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next,
| Iraise k ->
(instr_cons_debug (Iraise k) (subst_regs i.arg sub) [||] i.dbg i.next,
None)
(* Second pass: replace registers by their final representatives *)

17
asmrun/amd64.S
View File

@ -532,6 +532,8 @@ CFI_STARTPROC
popq %r14
ret
LBL(110):
STORE_VAR($0, caml_backtrace_pos)
LBL(111):
movq %rax, %r12 /* Save exception bucket */
movq %rax, C_ARG_1 /* arg 1: exception bucket */
#ifdef WITH_FRAME_POINTERS
@ -553,18 +555,27 @@ LBL(110):
ret
CFI_ENDPROC
FUNCTION(G(caml_reraise_exn))
CFI_STARTPROC
TESTL_VAR($1, caml_backtrace_active)
jne LBL(111)
movq %r14, %rsp
popq %r14
ret
CFI_ENDPROC
/* Raise an exception from C */
FUNCTION(G(caml_raise_exception))
CFI_STARTPROC
TESTL_VAR($1, caml_backtrace_active)
jne LBL(111)
jne LBL(112)
movq C_ARG_1, %rax
LOAD_VAR(caml_exception_pointer, %rsp) /* Cut stack */
popq %r14 /* Recover previous exception handler */
LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */
ret
LBL(111):
LBL(112):
#ifdef WITH_FRAME_POINTERS
ENTER_FUNCTION ;
#endif
@ -592,7 +603,7 @@ CFI_ENDPROC
backtrace anyway. */
FUNCTION(G(caml_stack_overflow))
LEA_VAR(caml_bucket_Stack_overflow, %rax)
LEA_VAR(caml_exn_Stack_overflow, %rax)
movq %r14, %rsp /* cut the stack */
popq %r14 /* recover previous exn handler */
ret /* jump to handler's code */

16
asmrun/amd64nt.asm
View File

@ -29,6 +29,7 @@
EXTRN caml_last_return_address: QWORD
EXTRN caml_gc_regs: QWORD
EXTRN caml_exception_pointer: QWORD
EXTRN caml_backtrace_pos: DWORD
EXTRN caml_backtrace_active: DWORD
EXTRN caml_stash_backtrace: NEAR
@ -306,6 +307,8 @@ caml_raise_exn:
pop r14 ; Recover previous exception handler
ret ; Branch to handler
L110:
mov caml_backtrace_pos, 0
L111:
mov r12, rax ; Save exception bucket in r12
mov rcx, rax ; Arg 1: exception bucket
mov rdx, [rsp] ; Arg 2: PC of raise
@ -318,19 +321,28 @@ L110:
pop r14 ; Recover previous exception handler
ret ; Branch to handler
PUBLIC caml_reraise_exn
ALIGN 16
caml_reraise_exn:
test caml_backtrace_active, 1
jne L111
mov rsp, r14 ; Cut stack
pop r14 ; Recover previous exception handler
ret ; Branch to handler
; Raise an exception from C
PUBLIC caml_raise_exception
ALIGN 16
caml_raise_exception:
test caml_backtrace_active, 1
jne L111
jne L112
mov rax, rcx ; First argument is exn bucket
mov rsp, caml_exception_pointer
pop r14 ; Recover previous exception handler
mov r15, caml_young_ptr ; Reload alloc ptr
ret
L111:
L112:
mov r12, rcx ; Save exception bucket in r12
; Arg 1: exception bucket
mov rdx, caml_last_return_address ; Arg 2: PC of raise

65
asmrun/fail.c
View File

@ -13,6 +13,7 @@
/* Raising exceptions from C. */
#include <stdio.h>
#include <signal.h>
#include "alloc.h"
#include "fail.h"
@ -42,9 +43,6 @@ extern caml_generated_constant
caml_exn_Stack_overflow,
caml_exn_Assert_failure,
caml_exn_Undefined_recursive_module;
extern caml_generated_constant
caml_bucket_Out_of_memory,
caml_bucket_Stack_overflow;
/* Exception raising */
@ -73,13 +71,7 @@ void caml_raise(value v)
void caml_raise_constant(value tag)
{
CAMLparam1 (tag);
CAMLlocal1 (bucket);
bucket = caml_alloc_small (1, 0);
Field(bucket, 0) = tag;
caml_raise(bucket);
CAMLnoreturn;
caml_raise(tag);
}
void caml_raise_with_arg(value tag, value arg)
@ -124,22 +116,14 @@ void caml_invalid_argument (char const *msg)
caml_raise_with_string((value) caml_exn_Invalid_argument, msg);
}
/* To raise [Out_of_memory], we can't use [caml_raise_constant],
because it allocates and we're out of memory...
We therefore use a statically-allocated bucket constructed
by the ocamlopt linker.
This works OK because the exception value for [Out_of_memory] is also
statically allocated out of the heap.
The same applies to Stack_overflow. */
void caml_raise_out_of_memory(void)
{
caml_raise((value) &caml_bucket_Out_of_memory);
caml_raise_constant((value) caml_exn_Out_of_memory);
}
void caml_raise_stack_overflow(void)
{
caml_raise((value) &caml_bucket_Stack_overflow);
caml_raise_constant((value) caml_exn_Stack_overflow);
}
void caml_raise_sys_error(value msg)
@ -167,43 +151,22 @@ void caml_raise_sys_blocked_io(void)
caml_raise_constant((value) caml_exn_Sys_blocked_io);
}
/* We allocate statically the bucket for the exception because we can't
/* We use a pre-allocated exception because we can't
do a GC before the exception is raised (lack of stack descriptors
for the ccall to [caml_array_bound_error]. */
for the ccall to [caml_array_bound_error]). */
#define BOUND_MSG "index out of bounds"
#define BOUND_MSG_LEN (sizeof(BOUND_MSG) - 1)
static struct {
header_t hdr;
value exn;
value arg;
} array_bound_error_bucket;
static struct {
header_t hdr;
char data[BOUND_MSG_LEN + sizeof(value)];
} array_bound_error_msg = { 0, BOUND_MSG };
static int array_bound_error_bucket_inited = 0;
static value * caml_array_bound_error_exn = NULL;
void caml_array_bound_error(void)
{
if (! array_bound_error_bucket_inited) {
mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value);
mlsize_t offset_index = Bsize_wsize(wosize) - 1;
array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white);
array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN;
array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white);
array_bound_error_bucket.exn = (value) caml_exn_Invalid_argument;
array_bound_error_bucket.arg = (value) array_bound_error_msg.data;
array_bound_error_bucket_inited = 1;
caml_page_table_add(In_static_data,
&array_bound_error_msg,
&array_bound_error_msg + 1);
array_bound_error_bucket_inited = 1;
if (caml_array_bound_error_exn == NULL) {
caml_array_bound_error_exn = caml_named_value("Pervasives.array_bound_error");
if (caml_array_bound_error_exn == NULL) {
fprintf(stderr, "Fatal error: exception Invalid_argument(\"index out of bounds\")\n");
exit(2);
}
}
caml_raise((value) &array_bound_error_bucket.exn);
caml_raise(*caml_array_bound_error_exn);
}
int caml_is_special_exception(value exn) {

16
asmrun/i386.S
View File

@ -339,6 +339,8 @@ FUNCTION(caml_raise_exn)
UNDO_ALIGN_STACK(8)
ret
LBL(110):
movl $0, G(caml_backtrace_pos)
LBL(111):
movl %eax, %esi /* Save exception bucket in esi */
movl G(caml_exception_pointer), %edi /* SP of handler */
movl 0(%esp), %eax /* PC of raise */
@ -356,19 +358,29 @@ LBL(110):
ret
CFI_ENDPROC
FUNCTION(caml_reraise_exn)
CFI_STARTPROC
testl $1, G(caml_backtrace_active)
jne LBL(111)
movl G(caml_exception_pointer), %esp
popl G(caml_exception_pointer); CFI_ADJUST(-4)
UNDO_ALIGN_STACK(8)
ret
CFI_ENDPROC
/* Raise an exception from C */
FUNCTION(caml_raise_exception)
CFI_STARTPROC
PROFILE_C
testl $1, G(caml_backtrace_active)
jne LBL(111)
jne LBL(112)
movl 4(%esp), %eax
movl G(caml_exception_pointer), %esp
popl G(caml_exception_pointer); CFI_ADJUST(-4)
UNDO_ALIGN_STACK(8)
ret
LBL(111):
LBL(112):
movl 4(%esp), %esi /* Save exception bucket in esi */
ALIGN_STACK(12)
pushl G(caml_exception_pointer); CFI_ADJUST(4) /* 4: sp of handler */

18
asmrun/i386nt.asm
View File

@ -27,6 +27,7 @@
EXTERN _caml_last_return_address: DWORD
EXTERN _caml_gc_regs: DWORD
EXTERN _caml_exception_pointer: DWORD
EXTERN _caml_backtrace_pos: DWORD
EXTERN _caml_backtrace_active: DWORD
EXTERN _caml_stash_backtrace: PROC
@ -205,6 +206,8 @@ _caml_raise_exn:
pop _caml_exception_pointer
ret
L110:
mov _caml_backtrace_pos, 0
L111:
mov esi, eax ; Save exception bucket in esi
mov edi, _caml_exception_pointer ; SP of handler
mov eax, [esp] ; PC of raise
@ -219,18 +222,27 @@ L110:
pop _caml_exception_pointer
ret
; Raise an exception from C
PUBLIC _caml_reraise_exn
ALIGN 4
_caml_reraise_exn:
test _caml_backtrace_active, 1
jne L111
mov esp, _caml_exception_pointer
pop _caml_exception_pointer
ret
; Raise an exception from C
PUBLIC _caml_raise_exception
ALIGN 4
_caml_raise_exception:
test _caml_backtrace_active, 1
jne L111
jne L112
mov eax, [esp+4]
mov esp, _caml_exception_pointer
pop _caml_exception_pointer
ret
L111:
L112:
mov esi, [esp+4] ; Save exception bucket in esi
push _caml_exception_pointer ; arg 4: SP of handler
push _caml_bottom_of_stack ; arg 3: SP of raise

BIN
boot/myocamlbuild.boot
View File

Binary file not shown.

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

8
bytecomp/bytegen.ml
View File

@ -74,7 +74,7 @@ let make_branch cont =
match cont with
(Kbranch _ as branch) :: _ -> (branch, cont)
| (Kreturn _ as return) :: _ -> (return, cont)
| Kraise :: _ -> (Kraise, cont)
| Kraise k :: _ -> (Kraise k, cont)
| Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont
| _ -> make_branch_2 (None) 0 cont cont
@ -108,7 +108,7 @@ let rec add_pop n cont =
match cont with
Kpop m :: cont -> add_pop (n + m) cont
| Kreturn m :: cont -> Kreturn(n + m) :: cont
| Kraise :: _ -> cont
| Kraise _ :: _ -> cont
| _ -> Kpop n :: cont
(* Add the constant "unit" in front of a continuation *)
@ -584,8 +584,8 @@ let rec comp_expr env exp sz cont =
comp_expr env exp1 sz (Kstrictbranchif lbl ::
comp_expr env exp2 sz cont1)
end
| Lprim(Praise, [arg]) ->
comp_expr env arg sz (Kraise :: discard_dead_code cont)
| Lprim(Praise k, [arg]) ->
comp_expr env arg sz (Kraise k :: discard_dead_code cont)
| Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))])
when is_immed n ->
comp_expr env arg sz (Koffsetint n :: cont)

4
bytecomp/emitcode.ml
View File

@ -243,7 +243,9 @@ let emit_instr = function
| Kboolnot -> out opBOOLNOT
| Kpushtrap lbl -> out opPUSHTRAP; out_label lbl
| Kpoptrap -> out opPOPTRAP
| Kraise -> out opRAISE
| Kraise Raise_regular -> out opRAISE
| Kraise Raise_reraise -> out opRERAISE
| Kraise Raise_notrace -> out opRAISE_NOTRACE
| Kcheck_signals -> out opCHECK_SIGNALS
| Kccall(name, n) ->
if n <= 5

2
bytecomp/instruct.ml
View File

@ -85,7 +85,7 @@ type instruction =
| Kboolnot
| Kpushtrap of label
| Kpoptrap
| Kraise
| Kraise of raise_kind
| Kcheck_signals
| Kccall of string * int
| Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint

2
bytecomp/instruct.mli
View File

@ -105,7 +105,7 @@ type instruction =
| Kboolnot
| Kpushtrap of label
| Kpoptrap
| Kraise
| Kraise of raise_kind
| Kcheck_signals
| Kccall of string * int
| Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint

12
bytecomp/lambda.ml
View File

@ -41,7 +41,7 @@ type primitive =
(* External call *)
| Pccall of Primitive.description
(* Exceptions *)
| Praise
| Praise of raise_kind
(* Boolean operations *)
| Psequand | Psequor | Pnot
(* Integer operations *)
@ -137,6 +137,11 @@ and bigarray_layout =
| Pbigarray_c_layout
| Pbigarray_fortran_layout
and raise_kind =
| Raise_regular
| Raise_reraise
| Raise_notrace
type structured_constant =
Const_base of constant
| Const_pointer of int
@ -452,3 +457,8 @@ and negate_comparison = function
| Ceq -> Cneq| Cneq -> Ceq
| Clt -> Cge | Cle -> Cgt
| Cgt -> Cle | Cge -> Clt
let raise_kind = function
| Raise_regular -> "raise"
| Raise_reraise -> "reraise"
| Raise_notrace -> "raise_notrace"

9
bytecomp/lambda.mli
View File

@ -41,7 +41,7 @@ type primitive =
(* External call *)
| Pccall of Primitive.description
(* Exceptions *)
| Praise
| Praise of raise_kind
(* Boolean operations *)
| Psequand | Psequor | Pnot
(* Integer operations *)
@ -137,6 +137,11 @@ and bigarray_layout =
| Pbigarray_c_layout
| Pbigarray_fortran_layout
and raise_kind =
| Raise_regular
| Raise_reraise
| Raise_notrace
type structured_constant =
Const_base of constant
| Const_pointer of int
@ -232,3 +237,5 @@ val staticfail : lambda (* Anticipated static failure *)
(* Check anticipated failure, substitute its final value *)
val is_guarded: lambda -> bool
val patch_guarded : lambda -> lambda -> lambda
val raise_kind: raise_kind -> string

16
bytecomp/matching.ml
View File

@ -1678,7 +1678,7 @@ let rec do_tests_nofail tst arg = function
let make_test_sequence fail tst lt_tst arg const_lambda_list =
let rec make_test_sequence const_lambda_list =
if List.length const_lambda_list >= 4 && lt_tst <> Praise then
if List.length const_lambda_list >= 4 && lt_tst <> Pignore then
split_sequence const_lambda_list
else match fail with
| None -> do_tests_nofail tst arg const_lambda_list
@ -2098,7 +2098,7 @@ let combine_constant arg cst partial ctx def
fail arg 0 255 int_lambda_list
| Const_string _ ->
make_test_sequence
fail prim_string_notequal Praise arg const_lambda_list
fail prim_string_notequal Pignore arg const_lambda_list
| Const_float _ ->
make_test_sequence
fail
@ -2155,10 +2155,15 @@ let combine_constructor arg ex_pat cstr partial ctx def
| Some fail -> fail, tag_lambda_list in
List.fold_right
(fun (ex, act) rem ->
assert(ex = cstr.cstr_tag);
match ex with
| Cstr_exception (path, _) ->
let slot =
if cstr.cstr_arity = 0 then arg
else Lprim(Pfield 0, [arg])
in
Lifthenelse(Lprim(Pintcomp Ceq,
[Lprim(Pfield 0, [arg]); transl_path path]),
[slot; transl_path path]),
act, rem)
| _ -> assert false)
tests default in
@ -2728,7 +2733,7 @@ let compile_matching loc repr handler_fun arg pat_act_list partial =
let partial_function loc () =
(* [Location.get_pos_info] is too expensive *)
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable),
[transl_path Predef.path_match_failure;
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
@ -2740,7 +2745,8 @@ let for_function loc repr param pat_act_list partial =
(* In the following two cases, exhaustiveness info is not available! *)
let for_trywith param pat_act_list =
compile_matching Location.none None (fun () -> Lprim(Praise, [param]))
compile_matching Location.none None
(fun () -> Lprim(Praise Raise_reraise, [param]))
param pat_act_list Partial
let for_let loc param pat body =

2
bytecomp/printinstr.ml
View File

@ -67,7 +67,7 @@ let instruction ppf = function
| Kboolnot -> fprintf ppf "\tboolnot"
| Kpushtrap lbl -> fprintf ppf "\tpushtrap L%i" lbl
| Kpoptrap -> fprintf ppf "\tpoptrap"
| Kraise -> fprintf ppf "\traise"
| Kraise k-> fprintf ppf "\t%s" (Lambda.raise_kind k)
| Kcheck_signals -> fprintf ppf "\tcheck_signals"
| Kccall(s, n) ->
fprintf ppf "\tccall %s, %i" s n

2
bytecomp/printlambda.ml
View File

@ -105,7 +105,7 @@ let primitive ppf = function
| Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
| Plazyforce -> fprintf ppf "force"
| Pccall p -> fprintf ppf "%s" p.prim_name
| Praise -> fprintf ppf "raise"
| Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
| Psequand -> fprintf ppf "&&"
| Psequor -> fprintf ppf "||"
| Pnot -> fprintf ppf "not"

10
bytecomp/symtable.ml
View File

@ -134,13 +134,17 @@ let output_primitive_table outchan =
let init () =
(* Enter the predefined exceptions *)
Array.iter
(fun name ->
Array.iteri
(fun i name ->
let id =
try List.assoc name Predef.builtin_values
with Not_found -> fatal_error "Symtable.init" in
let c = slot_for_setglobal id in
let cst = Const_block(0, [Const_base(Const_string (name, None))]) in
let cst = Const_block(Obj.object_tag,
[Const_base(Const_string (name, None));
Const_base(Const_int (-i-1))
])
in
literal_table := (c, cst) :: !literal_table)
Runtimedef.builtin_exceptions;
(* Initialize the known C primitives *)

51
bytecomp/translcore.ml
View File

@ -146,7 +146,9 @@ let primitives_table = create_hashtable 57 [
"%setfield0", Psetfield(0, true);
"%makeblock", Pmakeblock(0, Immutable);
"%makemutable", Pmakeblock(0, Mutable);
"%raise", Praise;
"%raise", Praise Raise_regular;
"%reraise", Praise Raise_reraise;
"%raise_notrace", Praise Raise_notrace;
"%sequand", Psequand;
"%sequor", Psequor;
"%boolnot", Pnot;
@ -585,7 +587,7 @@ let primitive_is_ccall = function
let assert_failed exp =
let (fname, line, char) =
Location.get_pos_info exp.exp_loc.Location.loc_start in
Lprim(Praise, [event_after exp
Lprim(Praise Raise_regular, [event_after exp
(Lprim(Pmakeblock(0, Immutable),
[transl_path Predef.path_assert_failure;
Lconst(Const_block(0,
@ -601,6 +603,8 @@ let rec cut n l =
(* Translation of expressions *)
let try_ids = Hashtbl.create 8
let rec transl_exp e =
let eval_once =
(* Whether classes for immediate objects must be cached *)
@ -679,8 +683,17 @@ and transl_exp0 e =
(Warnings.Deprecated "operator (or); you should use (||) instead");
let prim = transl_prim e.exp_loc p args in
match (prim, args) with
(Praise, [arg1]) ->
wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
(Praise k, [arg1]) ->
let targ = List.hd argl in
let k =
match k, targ with
| Raise_regular, Lvar id
when Hashtbl.mem try_ids id ->
Raise_reraise
| _ ->
k
in
wrap0 (Lprim(Praise k, [event_after arg1 targ]))
| (_, _) ->
begin match (prim, argl) with
| (Plazyforce, [a]) ->
@ -701,7 +714,7 @@ and transl_exp0 e =
| Texp_try(body, pat_expr_list) ->
let id = name_pattern "exn" pat_expr_list in
Ltrywith(transl_exp body, id,
Matching.for_trywith (Lvar id) (transl_cases pat_expr_list))
Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list))
| Texp_tuple el ->
let ll = transl_list el in
begin try
@ -721,7 +734,9 @@ and transl_exp0 e =
Lprim(Pmakeblock(n, Immutable), ll)
end
| Cstr_exception (path, _) ->
Lprim(Pmakeblock(0, Immutable), transl_path path :: ll)
let slot = transl_path path in
if cstr.cstr_arity = 0 then slot
else Lprim(Pmakeblock(0, Immutable), slot :: ll)
end
| Texp_variant(l, arg) ->
let tag = Btype.hash_variant l in
@ -901,6 +916,20 @@ and transl_case {c_lhs; c_guard; c_rhs} =
and transl_cases cases =
List.map transl_case cases
and transl_case_try {c_lhs; c_guard; c_rhs} =
match c_lhs.pat_desc with
| Tpat_var (id, _)
| Tpat_alias (_, id, _) ->
Hashtbl.replace try_ids id ();
Misc.try_finally
(fun () -> c_lhs, transl_guard c_guard c_rhs)
(fun () -> Hashtbl.remove try_ids id)
| _ ->
c_lhs, transl_guard c_guard c_rhs
and transl_cases_try cases =
List.map transl_case_try cases
and transl_tupled_cases patl_expr_list =
List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr))
patl_expr_list
@ -1095,16 +1124,6 @@ let transl_let rec_flag pat_expr_list body =
(transl_let rec_flag pat_expr_list) body
*)
(* Compile an exception definition *)
let transl_exception path decl =
let name =
match path with
None -> Ident.name decl.cd_id
| Some p -> Path.name p in
Lprim(Pmakeblock(0, Immutable),
[Lconst(Const_base(Const_string (name,None)))])
(* Error report *)
open Format

2
bytecomp/translcore.mli
View File

@ -22,8 +22,6 @@ val transl_apply: lambda -> (label * expression option * optional) list
-> Location.t -> lambda
val transl_let: rec_flag -> value_binding list -> lambda -> lambda
val transl_primitive: Location.t -> Primitive.description -> lambda
val transl_exception:
Path.t option -> constructor_declaration -> lambda
val check_recursive_lambda: Ident.t list -> lambda -> bool

19
bytecomp/translmod.ml
View File

@ -27,8 +27,27 @@ open Translclass
type error =
Circular_dependency of Ident.t
exception Error of Location.t * error
(* Compile an exception definition *)
let prim_set_oo_id =
Pccall {Primitive.prim_name = "caml_set_oo_id"; prim_arity = 1;
prim_alloc = false; prim_native_name = "";
prim_native_float = false}
let transl_exception path decl =
let name =
match path with
None -> Ident.name decl.cd_id
| Some p -> Path.name p
in
Lprim(prim_set_oo_id,
[Lprim(Pmakeblock(Obj.object_tag, Immutable),
[Lconst(Const_base(Const_string (name,None)));
Lconst(Const_base(Const_int 0))])])
(* Compile a coercion *)
let rec apply_coercion restr arg =

7
byterun/backtrace.c
View File

@ -93,11 +93,11 @@ CAMLprim value caml_backtrace_status(value vunit)
/* Store the return addresses contained in the given stack fragment
into the backtrace array */
void caml_stash_backtrace(value exn, code_t pc, value * sp)
void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise)
{
code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
if (pc != NULL) pc = pc - 1;
if (exn != caml_backtrace_last_exn) {
if (exn != caml_backtrace_last_exn || !reraise) {
caml_backtrace_pos = 0;
caml_backtrace_last_exn = exn;
}
@ -282,7 +282,8 @@ static void extract_location_info(value events, code_t pc,
value ev, ev_start;
ev = event_for_location(events, pc);
li->loc_is_raise = caml_is_instruction(*pc, RAISE);
li->loc_is_raise = caml_is_instruction(*pc, RAISE) ||
caml_is_instruction(*pc, RERAISE);
if (ev == Val_false) {
li->loc_valid = 0;
return;

2
byterun/backtrace.h
View File

@ -24,7 +24,7 @@ CAMLextern char * caml_cds_file;
CAMLprim value caml_record_backtrace(value vflag);
#ifndef NATIVE_CODE
extern void caml_stash_backtrace(value exn, code_t pc, value * sp);
extern void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise);
#endif
CAMLextern void caml_print_exception_backtrace(void);

2
byterun/compact.c
View File

@ -40,7 +40,7 @@ extern void caml_shrink_heap (char *); /* memory.c */
XXX Should be fixed:
XXX The above assumes that all roots are aligned on a 4-byte boundary,
XXX which is not always guaranteed by C.
XXX (see [caml_register_global_roots] and [caml_init_exceptions])
XXX (see [caml_register_global_roots])
XXX Should be able to fix it to only assume 2-byte alignment.
*/
#define Make_ehd(s,t,c) (((s) << 10) | (t) << 2 | (c))

1
byterun/compatibility.h
View File

@ -112,7 +112,6 @@
#define raise_zero_divide caml_raise_zero_divide
#define raise_not_found caml_raise_not_found
#define raise_sys_blocked_io caml_raise_sys_blocked_io
#define init_exceptions caml_init_exceptions
/* **** asmrun/fail.c */
/* **** asmrun/<arch>.s */

2
byterun/exec.h
View File

@ -54,7 +54,7 @@ struct exec_trailer {
/* Magic number for this release */
#define EXEC_MAGIC "Caml1999X008"
#define EXEC_MAGIC "Caml1999X010"
#endif /* CAML_EXEC_H */

31
byterun/fail.c
View File

@ -39,13 +39,7 @@ CAMLexport void caml_raise(value v)
CAMLexport void caml_raise_constant(value tag)
{
CAMLparam1 (tag);
CAMLlocal1 (bucket);
bucket = caml_alloc_small (1, 0);
Field(bucket, 0) = tag;
caml_raise(bucket);
CAMLnoreturn;
caml_raise(tag);
}
CAMLexport void caml_raise_with_arg(value tag, value arg)
@ -111,21 +105,9 @@ CAMLexport void caml_array_bound_error(void)
caml_invalid_argument("index out of bounds");
}
/* Problem: we can't use [caml_raise_constant], because it allocates and
we're out of memory... Here, we allocate statically the exn bucket
for [Out_of_memory]. */
static struct {
header_t hdr;
value exn;
} out_of_memory_bucket = { 0, 0 };
CAMLexport void caml_raise_out_of_memory(void)
{
if (out_of_memory_bucket.exn == 0)
caml_fatal_error
("Fatal error: out of memory while raising Out_of_memory\n");
caml_raise((value) &(out_of_memory_bucket.exn));
caml_raise_constant(Field(caml_global_data, OUT_OF_MEMORY_EXN));
}
CAMLexport void caml_raise_stack_overflow(void)
@ -158,15 +140,6 @@ CAMLexport void caml_raise_sys_blocked_io(void)
caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO));
}
/* Initialization of statically-allocated exception buckets */
void caml_init_exceptions(void)
{
out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white);
out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN);
caml_register_global_root(&out_of_memory_bucket.exn);
}
int caml_is_special_exception(value exn) {
return exn == Field(caml_global_data, MATCH_FAILURE_EXN)
|| exn == Field(caml_global_data, ASSERT_FAILURE_EXN)

1
byterun/fail.h
View File

@ -74,7 +74,6 @@ CAMLextern void caml_raise_sys_error (value) Noreturn;
CAMLextern void caml_raise_end_of_file (void) Noreturn;
CAMLextern void caml_raise_zero_divide (void) Noreturn;
CAMLextern void caml_raise_not_found (void) Noreturn;
CAMLextern void caml_init_exceptions (void);
CAMLextern void caml_array_bound_error (void) Noreturn;
CAMLextern void caml_raise_sys_blocked_io (void) Noreturn;

4
byterun/instruct.h
View File

@ -39,7 +39,9 @@ enum instructions {
VECTLENGTH, GETVECTITEM, SETVECTITEM,
GETSTRINGCHAR, SETSTRINGCHAR,
BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT,
PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS,
PUSHTRAP, POPTRAP, RAISE,
RERAISE, RAISE_NOTRACE,
CHECK_SIGNALS,
C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN,
CONST0, CONST1, CONST2, CONST3, CONSTINT,
PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT,

21
byterun/intern.c
View File

@ -64,10 +64,6 @@ static value intern_block;
/* Point to the heap block allocated as destination block.
Meaningful only if intern_extra_block is NULL. */
static value * camlinternaloo_last_id = NULL;
/* Pointer to a reference holding the last object id.
-1 means not available (CamlinternalOO not loaded). */
static char * intern_resolve_code_pointer(unsigned char digest[16],
asize_t offset);
static void intern_bad_code_pointer(unsigned char digest[16]) Noreturn;
@ -290,16 +286,9 @@ static void intern_rec(value *dest)
switch (sp->op) {
case OFreshOID:
/* Refresh the object ID */
if (camlinternaloo_last_id == NULL) {
camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id");
if (camlinternaloo_last_id == NULL)
camlinternaloo_last_id = (value*) (-1);
}
if (camlinternaloo_last_id != (value*) (-1)) {
value id = Field(*camlinternaloo_last_id,0);
Field(dest, 0) = id;
Field(*camlinternaloo_last_id,0) = id + 2;
}
/* but do not do it for predefined exception slots */
if (Int_val(Field(dest, 1)) >= 0)
caml_set_oo_id((value)dest);
/* Pop item and iterate */
sp--;
break;
@ -336,7 +325,7 @@ static void intern_rec(value *dest)
/* Request freshing OID */
PushItem();
sp->op = OFreshOID;
sp->dest = &Field(v, 1);
sp->dest = v;
sp->arg = 1;
/* Finally read first two block elements: method table and old OID */
ReadItems(&Field(v, 0), 2);
@ -503,8 +492,6 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
{
mlsize_t wosize;
if (camlinternaloo_last_id == (value*)-1)
camlinternaloo_last_id = NULL; /* Reset ignore flag */
if (whsize == 0) {
intern_obj_table = NULL;
intern_extra_block = NULL;

12
byterun/interp.c
View File

@ -820,10 +820,20 @@ value caml_interprete(code_t prog, asize_t prog_size)
sp += 4;
Next;
Instruct(RAISE_NOTRACE):
if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
goto raise_notrace;
Instruct(RERAISE):
if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 1);
goto raise_notrace;
Instruct(RAISE):
raise_exception:
if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp);
if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 0);
raise_notrace:
if ((char *) caml_trapsp
>= (char *) caml_stack_high - initial_sp_offset) {
caml_external_raise = initial_external_raise;

1
byterun/mlvalues.h
View File

@ -300,5 +300,6 @@ extern value caml_global_data;
}
#endif
CAMLextern value caml_set_oo_id(value obj);
#endif /* CAML_MLVALUES_H */

8
byterun/obj.c
View File

@ -247,3 +247,11 @@ value caml_cache_public_method2 (value *meths, value tag, value *cache)
}
}
#endif /*CAML_JIT*/
static value oo_last_id = Val_int(0);
CAMLprim value caml_set_oo_id (value obj) {
Field(obj, 1) = oo_last_id;
oo_last_id += 2;
return obj;
}

8
byterun/printexc.c
View File

@ -53,8 +53,8 @@ CAMLexport char * caml_format_exception(value exn)
buf.ptr = buf.data;
buf.end = buf.data + sizeof(buf.data) - 1;
add_string(&buf, String_val(Field(Field(exn, 0), 0)));
if (Wosize_val(exn) >= 2) {
if (Tag_val(exn) == 0) {
add_string(&buf, String_val(Field(Field(exn, 0), 0)));
/* Check for exceptions in the style of Match_failure and Assert_failure */
if (Wosize_val(exn) == 2 &&
Is_block(Field(exn, 1)) &&
@ -82,7 +82,9 @@ CAMLexport char * caml_format_exception(value exn)
}
}
add_char(&buf, ')');
}
} else
add_string(&buf, String_val(Field(exn, 0)));
*buf.ptr = 0; /* Terminate string */
i = buf.ptr - buf.data + 1;
res = malloc(i);

2
byterun/startup.c
View File

@ -429,7 +429,6 @@ CAMLexport void caml_main(char **argv)
caml_oldify_one (caml_global_data, &caml_global_data);
caml_oldify_mopup ();
/* Initialize system libraries */
caml_init_exceptions();
caml_sys_init(exe_name, argv + pos);
#ifdef _WIN32
/* Start a thread to handle signals */
@ -514,7 +513,6 @@ CAMLexport void caml_startup_code(
caml_section_table = section_table;
caml_section_table_size = section_table_size;
/* Initialize system libraries */
caml_init_exceptions();
caml_sys_init(exe_name, argv);
/* Execute the program */
caml_debugger(PROGRAM_START);

12
otherlibs/threads/pervasives.ml
View File

@ -19,7 +19,16 @@
(* Exceptions *)
external register_named_value : string -> 'a -> unit
= "caml_register_named_value"
let () =
(* for asmrun/fail.c *)
register_named_value "Pervasives.array_bound_error"
(Invalid_argument "index out of bounds")
external raise : exn -> 'a = "%raise"
external raise_notrace : exn -> 'a = "%raise_notrace"
let failwith s = raise(Failure s)
let invalid_arg s = raise(Invalid_argument s)
@ -547,7 +556,4 @@ let exit retcode =
do_at_exit ();
sys_exit retcode
external register_named_value : string -> 'a -> unit
= "caml_register_named_value"
let _ = register_named_value "Pervasives.do_at_exit" do_at_exit

4
stdlib/callback.ml
View File

@ -20,4 +20,6 @@ let register name v =
register_named_value name (Obj.repr v)
let register_exception name (exn : exn) =
register_named_value name (Obj.field (Obj.repr exn) 0)
let exn = Obj.repr exn in
let slot = if Obj.tag exn = Obj.object_tag then exn else Obj.field exn 0 in
register_named_value name slot

17
stdlib/camlinternalOO.ml
View File

@ -15,20 +15,13 @@ open Obj
(**** Object representation ****)
let last_id = ref 0
let () = Callback.register "CamlinternalOO.last_id" last_id
let set_id o id =
let id0 = !id in
Array.unsafe_set (Obj.magic o : int array) 1 id0;
id := id0 + 1
external set_id: 'a -> 'a = "caml_set_oo_id" "noalloc"
(**** Object copy ****)
let copy o =
let o = (Obj.obj (Obj.dup (Obj.repr o))) in
set_id o last_id;
o
set_id o
(**** Compression options ****)
(* Parameters *)
@ -359,8 +352,7 @@ let create_object table =
let obj = Obj.new_block Obj.object_tag table.size in
(* XXX Appel de [caml_modify] *)
Obj.set_field obj 0 (Obj.repr table.methods);
set_id obj last_id;
(Obj.obj obj)
Obj.obj (set_id obj)
let create_object_opt obj_0 table =
if (Obj.magic obj_0 : bool) then obj_0 else begin
@ -368,8 +360,7 @@ let create_object_opt obj_0 table =
let obj = Obj.new_block Obj.object_tag table.size in
(* XXX Appel de [caml_modify] *)
Obj.set_field obj 0 (Obj.repr table.methods);
set_id obj last_id;
(Obj.obj obj)
Obj.obj (set_id obj)
end
let rec iter_f obj =

13
stdlib/pervasives.ml
View File

@ -15,7 +15,17 @@
(* Exceptions *)
external register_named_value : string -> 'a -> unit
= "caml_register_named_value"
let () =
(* for asmrun/fail.c *)
register_named_value "Pervasives.array_bound_error"
(Invalid_argument "index out of bounds")
external raise : exn -> 'a = "%raise"
external raise_notrace : exn -> 'a = "%raise_notrace"
let failwith s = raise(Failure s)
let invalid_arg s = raise(Invalid_argument s)
@ -454,7 +464,4 @@ let exit retcode =
do_at_exit ();
sys_exit retcode
external register_named_value : string -> 'a -> unit
= "caml_register_named_value"
let _ = register_named_value "Pervasives.do_at_exit" do_at_exit

5
stdlib/pervasives.mli
View File

@ -28,6 +28,11 @@
external raise : exn -> 'a = "%raise"
(** Raise the given exception value *)
external raise_notrace : exn -> 'a = "%raise_notrace"
(** A faster version [raise] which does not record the backtrace.
@since 4.02.0
*)
val invalid_arg : string -> 'a
(** Raise exception [Invalid_argument] with the given string. *)

22
stdlib/printexc.ml
View File

@ -58,9 +58,12 @@ let to_string x =
sprintf locfmt file line char (char+6) "Undefined recursive module"
| _ ->
let x = Obj.repr x in
let constructor =
(Obj.magic (Obj.field (Obj.field x 0) 0) : string) in
constructor ^ (fields x) in
if Obj.tag x <> 0 then
(Obj.magic (Obj.field x 0) : string)
else
let constructor =
(Obj.magic (Obj.field (Obj.field x 0) 0) : string) in
constructor ^ (fields x) in
conv !printers
let print fct arg =
@ -168,3 +171,16 @@ let register_printer fn =
external get_callstack: int -> raw_backtrace = "caml_get_current_callstack"
let exn_slot x =
let x = Obj.repr x in
if Obj.tag x = 0 then Obj.field x 0 else x
let exn_slot_id x =
let slot = exn_slot x in
(Obj.obj (Obj.field slot 1) : int)
let exn_slot_name x =
let slot = exn_slot x in
(Obj.obj (Obj.field slot 0) : string)

20
stdlib/printexc.mli
View File

@ -112,3 +112,23 @@ val get_callstack: int -> raw_backtrace
@since 4.01.0
*)
(** {6 Exception slots} *)
val exn_slot_id: exn -> int
(** [Printexc.exn_slot_id] returns an integer which uniquely identifies
the constructor used to create the exception value [exn]
(in the current runtime).
@since 4.02.0
*)
val exn_slot_name: exn -> string
(** [Printexc.exn_slot_id exn] returns the internal name of the constructor
used to create the exception value [exn].
@since 4.02.0
*)

4
testsuite/tests/asmcomp/lexcmm.mll
View File

@ -57,7 +57,9 @@ let keyword_table =
"mod", MODI;
"or", OR;
"proj", PROJ;
"raise", RAISE;
"raise", RAISE Lambda.Raise_regular;
"reraise", RAISE Lambda.Raise_reraise;
"raise_notrace", RAISE Lambda.Raise_notrace;
"seq", SEQ;
"signed", SIGNED;
"skip", SKIP;

4
testsuite/tests/asmcomp/parsecmm.mly
View File

@ -108,7 +108,7 @@ let access_array base numelt size =
%token OR
%token <int> POINTER
%token PROJ
%token RAISE
%token <Lambda.raise_kind> RAISE
%token RBRACKET
%token RPAREN
%token SEQ
@ -247,7 +247,7 @@ unaryop:
| ALLOC { Calloc }
| FLOATOFINT { Cfloatofint }
| INTOFFLOAT { Cintoffloat }
| RAISE { Craise Debuginfo.none }
| RAISE { Craise ($1, Debuginfo.none) }
| ABSF { Cabsf }
;
binaryop:

12
testsuite/tests/typing-objects/Tests.ml.principal.reference
View File

@ -295,12 +295,12 @@ Warning 10: this expression should have type unit.
unit -> object method private m : int method n : int method o : int end
# - : int * int = (1, 1)
# class c : unit -> object method m : int end
# - : int = 16
# - : int = 17
# - : int = 18
# - : int * int * int = (19, 20, 21)
# - : int * int * int * int * int = (22, 23, 24, 33, 33)
# - : int * int * int * int * int = (25, 26, 27, 33, 33)
# - : int = 95
# - : int = 96
# - : int = 97
# - : int * int * int = (98, 99, 100)
# - : int * int * int * int * int = (101, 102, 103, 33, 33)
# - : int * int * int * int * int = (104, 105, 106, 33, 33)
# Characters 42-69:
class a = let _ = new b in object end
^^^^^^^^^^^^^^^^^^^^^^^^^^^

12
testsuite/tests/typing-objects/Tests.ml.reference
View File

@ -294,12 +294,12 @@ Warning 10: this expression should have type unit.
unit -> object method private m : int method n : int method o : int end
# - : int * int = (1, 1)
# class c : unit -> object method m : int end
# - : int = 16
# - : int = 17
# - : int = 18
# - : int * int * int = (19, 20, 21)
# - : int * int * int * int * int = (22, 23, 24, 33, 33)
# - : int * int * int * int * int = (25, 26, 27, 33, 33)
# - : int = 95
# - : int = 96
# - : int = 97
# - : int * int * int = (98, 99, 100)
# - : int * int * int * int * int = (101, 102, 103, 33, 33)
# - : int * int * int * int * int = (104, 105, 106, 33, 33)
# Characters 42-69:
class a = let _ = new b in object end
^^^^^^^^^^^^^^^^^^^^^^^^^^^

11
toplevel/genprintval.ml
View File

@ -79,6 +79,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
else []
let outval_of_untyped_exception bucket =
if O.tag bucket <> 0 then
Oval_constr (Oide_ident (O.obj (O.field bucket 0) : string), [])
else
let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
let args =
if (name = "Match_failure"
@ -349,7 +352,11 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
Oval_constr (lid, args)
and tree_of_exception depth bucket =
let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
let slot =
if O.tag bucket <> 0 then bucket
else O.field bucket 0
in
let name = (O.obj(O.field slot 0) : string) in
let lid = Longident.parse name in
try
(* Attempt to recover the constructor description for the exn
@ -361,7 +368,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
(* Make sure this is the right exception and not an homonym,
by evaluating the exception found and comparing with the
identifier contained in the exception bucket *)
if not (EVP.same_value (O.field bucket 0) (EVP.eval_path path))
if not (EVP.same_value slot (EVP.eval_path path))
then raise Not_found;
tree_of_constr_with_args
(fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args

8
utils/config.mlbuild
View File

@ -60,10 +60,10 @@ let mkdll = C.mkdll
let mkexe = C.mkexe
let mkmaindll = C.mkmaindll
let exec_magic_number = "Caml1999X008"
and cmi_magic_number = "Caml1999I015"
and cmo_magic_number = "Caml1999O007"
and cma_magic_number = "Caml1999A008"
let exec_magic_number = "Caml1999X010"
and cmi_magic_number = "Caml1999I016"
and cmo_magic_number = "Caml1999O008"
and cma_magic_number = "Caml1999A009"
and cmx_magic_number = "Caml1999Y011"
and cmxa_magic_number = "Caml1999Z010"
and ast_impl_magic_number = "Caml1999M016"

8
utils/config.mlp
View File

@ -48,10 +48,10 @@ let mkdll = "%%MKDLL%%"
let mkexe = "%%MKEXE%%"
let mkmaindll = "%%MKMAINDLL%%"
let exec_magic_number = "Caml1999X008"
and cmi_magic_number = "Caml1999I015"
and cmo_magic_number = "Caml1999O007"
and cma_magic_number = "Caml1999A008"
let exec_magic_number = "Caml1999X010"
and cmi_magic_number = "Caml1999I016"
and cmo_magic_number = "Caml1999O008"
and cma_magic_number = "Caml1999A009"
and cmx_magic_number = "Caml1999Y011"
and cmxa_magic_number = "Caml1999Z010"
and ast_impl_magic_number = "Caml1999M016"