Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

no-naked-pointers patch

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14791 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
commit 881ec04f39128569be1661b9c07b1410fcca6e37 1 parent 48ecf7e
@mshinwell mshinwell authored
View
36 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)
View
BIN  boot/ocamlc
Binary file not shown
View
BIN  boot/ocamldep
Binary file not shown
View
BIN  boot/ocamllex
Binary file not shown
View
35 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);
View
12 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"
Please sign in to comment.
Something went wrong with that request. Please try again.