no-naked-pointers patch

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

asmcomp/cmmgen.ml

@@ -38,6 +38,8 @@ let bind_nonvar name arg fn =
   | Cconst_blockheader _ -> fn arg
   | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
 
+let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8  (* cf. byterun/gc.h *)
+
 (* Block headers. Meaning of the tag field: see stdlib/obj.ml *)
 
 let floatarray_tag = Cconst_int Obj.double_array_tag
@@ -45,7 +47,12 @@ let floatarray_tag = Cconst_int Obj.double_array_tag
 let block_header tag sz =
   Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10)
                 (Nativeint.of_int tag)
-let closure_header sz = block_header Obj.closure_tag sz
+(* Static data corresponding to "value"s must be marked black in case we are
+   in no-naked-pointers mode.  See [caml_darken] and the code below that emits
+   structured constants and static module definitions. *)
+let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black
+let white_closure_header sz = block_header Obj.closure_tag sz
+let black_closure_header sz = black_block_header Obj.closure_tag sz
 let infix_header ofs = block_header Obj.infix_tag ofs
 let float_header = block_header Obj.double_tag (size_float / size_addr)
 let floatarray_header len =
@@ -59,7 +66,7 @@ let boxedintnat_header = block_header Obj.custom_tag 2
 let alloc_block_header tag sz = Cconst_blockheader(block_header tag sz)
 let alloc_float_header = Cconst_blockheader(float_header)
 let alloc_floatarray_header len = Cconst_blockheader(floatarray_header len)
-let alloc_closure_header sz = Cconst_blockheader(closure_header sz)
+let alloc_closure_header sz = Cconst_blockheader(white_closure_header sz)
 let alloc_infix_header ofs = Cconst_blockheader(infix_header ofs)
 let alloc_boxedint32_header = Cconst_blockheader(boxedint32_header)
 let alloc_boxedint64_header = Cconst_blockheader(boxedint64_header)
@@ -2202,10 +2209,13 @@ let rec transl_all_functions already_translated cont =
 
 (* Emit structured constants *)
 
-let emit_block header symb cont =
-  Cint header :: Cdefine_symbol symb :: cont
-
 let rec emit_structured_constant symb cst cont =
+  let emit_block white_header symb cont =
+    (* Headers for structured constants must be marked black in case we
+       are in no-naked-pointers mode.  See [caml_darken]. *)
+    let black_header = Nativeint.logor white_header caml_black in
+    Cint black_header :: Cdefine_symbol symb :: cont
+  in
   match cst with
   | Uconst_float s->
       emit_block float_header symb (Cdouble s :: cont)
@@ -2282,7 +2292,7 @@ let emit_constant_closure symb fundecls cont =
             Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) ::
             Csymbol_address f2.label ::
             emit_others (pos + 4) rem in
-      Cint(closure_header (fundecls_size fundecls)) ::
+      Cint(black_closure_header (fundecls_size fundecls)) ::
       Cdefine_symbol symb ::
       if f1.arity = 1 then
         Csymbol_address f1.label ::
@@ -2324,10 +2334,18 @@ let compunit size ulam =
                        fun_dbg  = Debuginfo.none }] in
   let c2 = transl_all_functions StringSet.empty c1 in
   let c3 = emit_all_constants c2 in
-  Cdata [Cint(block_header 0 size);
+  let space =
+    (* These words will be registered as roots and as such must contain
+       valid values, in case we are in no-naked-pointers mode.  Likewise
+       the block header must be black, below (see [caml_darken]), since
+       the overall record may be referenced. *)
+    Array.to_list
+      (Array.init size (fun _index ->
+        Cint (Nativeint.of_int 1 (* Val_unit *))))
+  in
+  Cdata ([Cint(black_block_header 0 size);
          Cglobal_symbol glob;
-         Cdefine_symbol glob;
-         Cskip(size * size_addr)] :: c3
+         Cdefine_symbol glob] @ space) :: c3
 
 (*
 CAMLprim value caml_cache_public_method (value meths, value tag, value *cache)

byterun/major_gc.c

@@ -27,6 +27,12 @@
 #include "roots.h"
 #include "weak.h"
 
+#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS)
+#define NATIVE_CODE_AND_NO_NAKED_POINTERS
+#else
+#undef NATIVE_CODE_AND_NO_NAKED_POINTERS
+#endif
+
 uintnat caml_percent_free;
 uintnat caml_major_heap_increment;
 CAMLexport char *caml_heap_start;
@@ -82,7 +88,18 @@ static void realloc_gray_vals (void)
 
 void caml_darken (value v, value *p /* not used */)
 {
+#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
+  if (Is_block (v) && Wosize_val (v) > 0) {
+    /* We insist that naked pointers to outside the heap point to things that
+       look like values with headers coloured black.  This isn't always
+       strictly necessary but is essential in certain cases---in particular
+       when the value is allocated in a read-only section.  (For the values
+       where it would be safe it is a performance improvement since we avoid
+       putting them on the grey list.) */
+    CAMLassert (Is_in_heap (v) || Is_black_hd (Hd_val (v)));
+#else
   if (Is_block (v) && Is_in_heap (v)) {
+#endif
     header_t h = Hd_val (v);
     tag_t t = Tag_hd (h);
     if (t == Infix_tag){
@@ -124,6 +141,9 @@ static void mark_slice (intnat work)
   value v, child;
   header_t hd;
   mlsize_t size, i;
+#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
+  int marking_closure = 0;
+#endif
 
   caml_gc_message (0x40, "Marking %ld words\n", work);
   caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase);
@@ -132,13 +152,28 @@ static void mark_slice (intnat work)
     if (gray_vals_ptr > gray_vals){
       v = *--gray_vals_ptr;
       hd = Hd_val(v);
+#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
+      marking_closure =
+        (Tag_hd (hd) == Closure_tag || Tag_hd (hd) == Infix_tag);
+#endif
       Assert (Is_gray_hd (hd));
       Hd_val (v) = Blackhd_hd (hd);
       size = Wosize_hd (hd);
       if (Tag_hd (hd) < No_scan_tag){
         for (i = 0; i < size; i++){
           child = Field (v, i);
+#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
+          if (Is_block (child)
+                && Wosize_val (child) > 0  /* Atoms never need to be marked. */
+                /* Closure blocks contain code pointers at offsets that cannot
+                   be reliably determined, so we always use the page table when
+                   marking such values. */
+                && (!marking_closure || Is_in_heap (child))) {
+            /* See [caml_darken] for a description of this assertion. */
+            CAMLassert (Is_in_heap (child) || Is_black_hd (Hd_val (child)));
+#else
           if (Is_block (child) && Is_in_heap (child)) {
+#endif
             hd = Hd_val (child);
             if (Tag_hd (hd) == Forward_tag){
               value f = Forward_val (child);

configure

@@ -43,6 +43,7 @@ with_debugger=ocamldebugger
 with_ocamldoc=ocamldoc
 with_ocamlbuild=ocamlbuild
 with_frame_pointers=false
+no_naked_pointers=false
 TOOLPREF=""
 with_cfi=true
 
@@ -150,6 +151,8 @@ while : ; do
         with_ocamlbuild="";;
     -with-frame-pointers|--with-frame-pointers)
         with_frame_pointers=true;;
+    -no-naked-pointers|--no-naked-pointers)
+        no_naked_pointers=true;;
     -no-cfi|--no-cfi)
         with_cfi=false;;
     *) err "Unknown option \"$1\".";;
@@ -1602,6 +1605,9 @@ if test "$with_frame_pointers" = "true"; then
 
 fi
 
+if $no_naked_pointers; then
+  echo "#define NO_NAKED_POINTERS" >> m.h
+fi
 
 # Final twiddling of compiler options to work around known bugs
 
@@ -1738,7 +1744,11 @@ else
   else
   inf "        with frame pointers....... no"
   fi
-  echo "        native dynlink ........... $natdynlink"
+  if $no_naked_pointers; then
+  inf "        naked pointers forbidden.. yes"
+  else
+  inf "        naked pointers forbidden.. no"
+  fi
   inf "        native dynlink ........... $natdynlink"
   if test "$profiling" = "prof"; then
   inf "        profiling with gprof ..... supported"