En ocamlopt, les acces hors bornes levent Invalid_argument au lieu de planter le programme. Itou pour les fonctions C qui appellent invalid_argument. Teste sur Intel, a tester sur les autres

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2165 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Author: xavierleroy

Diff for: asmcomp/alpha/emit.mlp

@@ -709,8 +709,8 @@ let emit_fundecl (fundecl, needs_gp) =
   List.iter emit_call_gc !call_gc_sites;
   if !range_check_trap > 0 then begin
     `{emit_label !range_check_trap}:\n`;
-    `	br	$25, call_array_bound_error\n`
-    (* Keep retaddr in $25 for debugging *)
+    `	br	$26, caml_array_bound_error\n`
+    (* Keep retaddr in $26 for debugging *)
   end;
   `	.end	{emit_symbol fundecl.fun_name}\n`;
   if !bigint_constants <> [] then begin

Diff for: asmcomp/arm/emit.mlp

@@ -382,7 +382,7 @@ let emit_instr i =
         `	mov{emit_string comp}	{emit_reg i.res.(0)}, #1\n`; 3
     | Lop(Iintop(Icheckbound)) ->
         `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-        `	blls	array_bound_error\n`; 2
+        `	blls	caml_array_bound_error\n`; 2
     | Lop(Iintop op) ->
         let instr = name_for_int_operation op in
         `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1
@@ -419,7 +419,7 @@ let emit_instr i =
         `	mov{emit_string comp}	{emit_reg i.res.(0)}, #1\n`; 3
     | Lop(Iintop_imm(Icheckbound, n)) ->
         `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
-        `	blls	array_bound_error\n`; 2
+        `	blls	caml_array_bound_error\n`; 2
     | Lop(Iintop_imm(op, n)) ->
         let instr = name_for_int_operation op in
         `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
@@ -438,7 +438,7 @@ let emit_instr i =
         1
     | Lop(Ispecific(Ishiftcheckbound shift)) ->
         `	cmp	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
-        `	blcs	array_bound_error\n`; 2
+        `	blcs	caml_array_bound_error\n`; 2
     | Lop(Ispecific(Irevsubimm n)) ->
 	`	rsb	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
     | Lreloadretaddr ->

Diff for: asmcomp/hppa/emit.mlp

@@ -972,11 +972,11 @@ let fundecl fundecl =
   if !range_check_trap > 0 then begin
     `{emit_label !range_check_trap}:\n`;
     if hpux then begin
-      emit_call "array_bound_error" "%r31";
+      emit_call "caml_array_bound_error" "%r31";
       `	nop\n`
     end else begin
-      `	ldil	L\`{emit_symbol "array_bound_error"}, %r1\n`;
-      `	ble,n	{emit_symbol_low "array_bound_error"}(4, %r1)\n`
+      `	ldil	L\`{emit_symbol "caml_array_bound_error"}, %r1\n`;
+      `	ble,n	{emit_symbol_low "caml_array_bound_error"}(4, %r1)\n`
     end
   end;
   if hpux then begin

Diff for: asmcomp/liveness.ml

@@ -89,11 +89,12 @@ 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(_, _))
+        | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) ->
             (* 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
-               be live across the call. *)
+               nearest enclosing try ... with. Similarly for bounds checks.
+               Hence, everything that must be live at the beginning of
+               the exception handler must also be live across this instr. *)
              Reg.Set.union across_after !live_at_raise
          | _ ->
              across_after in

Diff for: asmcomp/m68k/emit.mlp

@@ -667,7 +667,7 @@ let fundecl fundecl =
   `{emit_label !tailrec_entry_point}:\n`;
   emit_all fundecl.fun_body;
   if !range_check_trap > 0 then
-    `{emit_label !range_check_trap}:	jbsr	{emit_symbol "array_bound_error"}\n`
+    `{emit_label !range_check_trap}:	jbsr	{emit_symbol "caml_array_bound_error"}\n`
 
 (* Emission of data *)
 

Diff for: asmcomp/mips/emit.mlp

@@ -551,7 +551,7 @@ let fundecl fundecl =
   end;
   if !range_check_trap > 0 then begin
     `{emit_label !range_check_trap}:\n`;
-    emit_branch_symbol "array_bound_error"
+    emit_branch_symbol "caml_array_bound_error"
   end;
   `	.end	{emit_symbol fundecl.fun_name}\n`
 

Diff for: asmrun/alpha.S

@@ -418,16 +418,17 @@ callback3:
         br      $107
         .end    callback3
 
-/* Glue code to call array_bound_error after reinitializing $gp */
+/* Glue code to call array_bound_error */
 
-        .globl  call_array_bound_error
-        .ent    call_array_bound_error
+        .globl  caml_array_bound_error
+        .ent    caml_array_bound_error
         .align  3
-call_array_bound_error:
+caml_array_bound_error:
         br      $27, $111
 $111:   ldgp    $gp, 0($27)
-        jsr     array_bound_error       /* never returns */
-        .end    call_array_bound_error
+        lda     $25, array_bound_error
+        br      caml_c_call             /* never returns */
+        .end    caml_array_bound_error
 
 #ifdef SYS_digital	
         .rdata

Diff for: asmrun/arm.S

@@ -312,6 +312,18 @@ callback3:
         ldr     r10, .Lcaml_apply3
         b       .Ljump_to_caml
 
+        .global caml_array_bound_error
+array_bound_error:
+    /* Save the exception handler and alloc ptr */
+        ldr     r6, .Lyoung_ptr
+        ldr     r7, .Lcaml_exception_pointer
+        str     alloc_ptr, [r6, #0]
+        str     trap_ptr, [r7, #0]
+    /* Load address of array_bound_error in r10 */
+        ldr     r10, .Larray_bound_error
+    /* Call that function */
+        b       caml_c_call
+
 /* Global references */
 
 .Lcaml_last_return_address:     .word caml_last_return_address
@@ -325,6 +337,7 @@ callback3:
 .Lcaml_apply2:                  .word caml_apply2
 .Lcaml_apply3:                  .word caml_apply3
 .Lcaml_requested_size:		.word 0
+.Larray_bound_error:            .word array_bound_error
 
 /* GC roots for callback */
 

Diff for: asmrun/fail.c

@@ -107,17 +107,9 @@ void failwith (char *msg)
   raise_with_string((value) Failure, msg);
 }
 
-/* We chose to abort the program if a C primitive raises Invalid_argument.
-   Rationale: nobody should trap Invalid_argument, and we're not running
-   under a toplevel, so this will provide the same feedback to the user.
-   Moreover, divisions by zero or out-of-bounds accesses also abort the
-   program, and there's no way we can turn them into exceptions.
-   Finally, this allows a number of C primitives to be declared "noalloc",
-   and this makes calling them much more efficient. */
-   
 void invalid_argument (char *msg)
 {
-  fatal_error_arg("Fatal_error: Invalid_argument \"%s\"\n", msg);
+  raise_with_string((value) Invalid_argument, msg);
 }
 
 /* To raise Out_of_memory, we can't use raise_constant,
@@ -157,3 +149,33 @@ void raise_not_found(void)
 {
   raise_constant((value) Not_found);
 }
+
+/* We allocate statically the bucket for the exception because we can't
+   do a GC before the exception is raised (lack of stack descriptors
+   for the ccall to array_bound_error  */
+
+#define BOUND_MSG "out-of-bound array or string access"
+#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 };
+
+void array_bound_error(void)
+{
+  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, White);
+  array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN;
+  array_bound_error_bucket.hdr = Make_header(2, 0, White);
+  array_bound_error_bucket.exn = (value) Invalid_argument;
+  array_bound_error_bucket.arg = (value) array_bound_error_msg.data;
+  mlraise((value) &array_bound_error_bucket.exn);
+}

Diff for: asmrun/hppa.S

@@ -523,6 +523,28 @@ G(callback3):
         ldo     LOW(G(caml_apply3))(%r1), %r22
         ENDPROC
 
+        .align  CODE_ALIGN
+        EXPORT_CODE(G(caml_array_bound_error))
+G(caml_array_bound_error):
+        STARTPROC
+; Save the exception handler
+        LOADHIGH(G(caml_exception_pointer))
+        stw     %r5, LOW(G(caml_exception_pointer))(%r1)
+; Save the allocation pointer
+        LOADHIGH(G(young_ptr))
+        stw     %r3, LOW(G(young_ptr))(%r1)
+; Load address of array_bound_error in %r22
+#ifdef SYS_hpux
+        ldil    LP'array_bound_error, %r22
+        ldo     RP'array_bound_error(%r22), %r22
+#else
+        ldil    L`_array_bound_error, %r22
+        ldo     R`_array_bound_error(%r22), %r22
+#endif
+; Jump to caml_c_call
+        b,n     G(caml_c_call)
+        ENDPROC
+
         .data
         EXPORT_DATA(G(system_frametable))
 G(system_frametable):

Diff for: asmrun/m68k.S

@@ -230,6 +230,15 @@ _callback3:
         lea     _caml_apply3, a5 | code pointer
         bra     L106
 
+        .globl  _caml_array_bound_error
+_caml_array_bound_error:
+    | Save allocation pointer and exception pointer
+        movel   d6, _young_ptr
+        movel   d7, _caml_exception_pointer
+    | Load address of array_bound_error in a0 and call it
+        lea     _array_bound_error, a0
+        bra     _caml_c_call
+
         .data
         .globl  _system_frametable
 _system_frametable:

Diff for: asmrun/mips.S

@@ -426,6 +426,21 @@ callback3:
 
         .end    callback3
 
+/* Glue code to call array_bound_error */
+
+        .globl  caml_array_bound_error
+        .ent    caml_array_bound_error
+
+caml_array_bound_error:
+#ifdef PIC
+        .set    noreorder
+        .cpload $25
+        .set    reorder
+#endif
+        la      $24, array_bound_error
+        b       caml_c_call             /* never returns */
+        .end    caml_array_bound_error
+
         .rdata
         .globl  system_frametable
 system_frametable: