diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 7e585b5c1..5ac1d1ad2 100644 --- a/asmcomp/cmmgen.ml +++ b/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) diff --git a/boot/ocamlc b/boot/ocamlc index c81a01baa..891a8cdb6 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index ed1e9277e..bc3cb94e1 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index f38063394..83291b9e8 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/byterun/major_gc.c b/byterun/major_gc.c index b3c25b817..a44c8d90a 100644 --- a/byterun/major_gc.c +++ b/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); diff --git a/configure b/configure index 58b114384..dfc9fe883 100755 --- a/configure +++ b/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"