diff --git a/asmcomp/cmm_helpers.ml b/asmcomp/cmm_helpers.ml index b841ab1b4f2..56f8e5b09ab 100644 --- a/asmcomp/cmm_helpers.ml +++ b/asmcomp/cmm_helpers.ml @@ -38,6 +38,7 @@ let bind_nonvar name arg fn = | _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id)) let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 +let caml_local = Nativeint.shift_left (Nativeint.of_int 2) 8 (* cf. runtime/caml/gc.h *) (* Block headers. Meaning of the tag field: see stdlib/obj.ml *) @@ -51,6 +52,7 @@ let block_header tag sz = 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 local_block_header tag sz = Nativeint.logor (block_header tag sz) caml_local 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 @@ -795,8 +797,12 @@ let call_cached_method obj tag cache pos args dbg = let make_alloc_generic ~mode set_fn dbg tag wordsize args = if mode = Lambda.Alloc_local || wordsize <= Config.max_young_wosize then - Cop(Calloc mode, - Cconst_natint(block_header tag wordsize, dbg) :: args, dbg) + let hdr = + match mode with + | Lambda.Alloc_local -> local_block_header tag wordsize + | Lambda.Alloc_heap -> block_header tag wordsize + in + Cop(Calloc mode, Cconst_natint(hdr, dbg) :: args, dbg) else begin let id = V.create_local "*alloc*" in let rec fill_fields idx = function diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index 2f3f1d10771..73d86789c5c 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -79,6 +79,7 @@ struct caml_thread_struct { value * gc_regs; /* Saved value of Caml_state->gc_regs */ char * exception_pointer; /* Saved value of Caml_state->exception_pointer */ struct caml__roots_block * local_roots; /* Saved value of local_roots */ + struct caml_local_arenas * local_arenas; struct longjmp_buffer * exit_buf; /* For thread exit */ #else value * stack_low; /* The execution stack for this thread */ @@ -148,8 +149,8 @@ static void caml_thread_scan_roots(scanning_action action) if (th != curr_thread) { #ifdef NATIVE_CODE if (th->bottom_of_stack != NULL) - caml_do_local_roots(action, th->bottom_of_stack, th->last_retaddr, - th->gc_regs, th->local_roots); + caml_do_local_roots(action, action, th->bottom_of_stack, th->last_retaddr, + th->gc_regs, th->local_roots, th->local_arenas); #else caml_do_local_roots(action, th->sp, th->stack_high, th->local_roots); #endif @@ -181,6 +182,7 @@ Caml_inline void caml_thread_save_runtime_state(void) curr_thread->last_retaddr = Caml_state->last_return_address; curr_thread->gc_regs = Caml_state->gc_regs; curr_thread->exception_pointer = Caml_state->exception_pointer; + curr_thread->local_arenas = caml_get_local_arenas(); #else curr_thread->stack_low = Caml_state->stack_low; curr_thread->stack_high = Caml_state->stack_high; @@ -204,6 +206,7 @@ Caml_inline void caml_thread_restore_runtime_state(void) Caml_state->last_return_address = curr_thread->last_retaddr; Caml_state->gc_regs = curr_thread->gc_regs; Caml_state->exception_pointer = curr_thread->exception_pointer; + caml_set_local_arenas(curr_thread->local_arenas); #else Caml_state->stack_low = curr_thread->stack_low; Caml_state->stack_high = curr_thread->stack_high; @@ -332,6 +335,7 @@ static caml_thread_t caml_thread_new_info(void) th->last_retaddr = 1; th->exception_pointer = NULL; th->local_roots = NULL; + th->local_arenas = NULL; th->exit_buf = NULL; #else /* Allocate the stacks */ diff --git a/runtime/caml/domain_state.tbl b/runtime/caml/domain_state.tbl index 4f19e8649e9..d543eb55e98 100644 --- a/runtime/caml/domain_state.tbl +++ b/runtime/caml/domain_state.tbl @@ -36,9 +36,11 @@ DOMAIN_STATE(struct caml_ephe_ref_table*, ephe_ref_table) DOMAIN_STATE(struct caml_custom_table*, custom_table) /* See minor_gc.c */ +DOMAIN_STATE(struct caml_local_arenas*, local_arenas) DOMAIN_STATE(intnat, local_sp) -DOMAIN_STATE(struct region_stack*, local_top) +DOMAIN_STATE(void*, local_top) DOMAIN_STATE(intnat, local_limit) + DOMAIN_STATE(intnat, local_total) DOMAIN_STATE(struct mark_stack*, mark_stack) diff --git a/runtime/caml/gc.h b/runtime/caml/gc.h index 854f9dba81f..f2b435e1cf7 100644 --- a/runtime/caml/gc.h +++ b/runtime/caml/gc.h @@ -64,4 +64,39 @@ #define Colornum_hd(hd) ((color_t) (((hd) >> 8) & 3)) #define Coloredhd_hd(hd,colnum) (((hd) & ~Caml_black) | ((colnum) << 8)) +#ifdef CAML_INTERNALS + + +#define Init_local_arena_bsize 4096 +#ifdef ARCH_SIXTYFOUR +#define Max_local_arenas 10 /* max 4G */ +#else +#define Max_local_arenas 8 /* max 1G */ +#endif + +struct caml_local_arena { + char* base; + uintnat length; +}; +typedef struct caml_local_arenas { + int count; + intnat saved_sp; + intnat next_length; + struct caml_local_arena arenas[Max_local_arenas]; +} caml_local_arenas; + +/* Colors for locally allocated values. + (Only used during root-scanning, never visible to the rest of the GC) */ +#define Local_marked Caml_black +#define Local_unmarked Caml_blue /* allocation color of local objects */ +#define Local_scanned Caml_gray + +#define With_color_hd(hd, color) \ + (((hd) & ~Caml_black) | color) + +/* Neither a valid header nor value */ +#define Local_uninit_hd Make_header(0, 0x42, Local_unmarked) + +#endif /* CAML_INTERNALS */ + #endif /* CAML_GC_H */ diff --git a/runtime/caml/memory.h b/runtime/caml/memory.h index fc831b37089..65feda06775 100644 --- a/runtime/caml/memory.h +++ b/runtime/caml/memory.h @@ -250,6 +250,9 @@ extern void caml_alloc_small_dispatch (intnat wosize, int flags, #define Modify(fp,val) caml_modify((fp), (val)) +struct caml_local_arenas* caml_get_local_arenas(); +void caml_set_local_arenas(struct caml_local_arenas* s); + #endif /* CAML_INTERNALS */ struct caml__roots_block { diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h index b7ffa4e7506..3ed2ba1e027 100644 --- a/runtime/caml/misc.h +++ b/runtime/caml/misc.h @@ -398,9 +398,11 @@ int caml_runtime_warnings_active(void); #define Debug_free_shrink Debug_tag (0x03) #define Debug_free_truncate Debug_tag (0x04) #define Debug_free_unused Debug_tag (0x05) +#define Debug_free_local Debug_tag (0x06) #define Debug_uninit_minor Debug_tag (0x10) #define Debug_uninit_major Debug_tag (0x11) #define Debug_uninit_align Debug_tag (0x15) +#define Debug_uninit_local Debug_tag (0x16) #define Debug_filler_align Debug_tag (0x85) #define Debug_pool_magic Debug_tag (0x99) diff --git a/runtime/caml/roots.h b/runtime/caml/roots.h index 8ac9d8d2635..1a60f10eea6 100644 --- a/runtime/caml/roots.h +++ b/runtime/caml/roots.h @@ -34,9 +34,11 @@ CAMLextern void caml_do_local_roots_byt (scanning_action, value *, value *, #define caml_do_local_roots caml_do_local_roots_byt #else CAMLextern void caml_do_local_roots_nat ( - scanning_action f, char * c_bottom_of_stack, + scanning_action maj, scanning_action min, + char * c_bottom_of_stack, uintnat last_retaddr, value * v_gc_regs, - struct caml__roots_block * gc_local_roots); + struct caml__roots_block * gc_local_roots, + struct caml_local_arenas* local_arenas); #define caml_do_local_roots caml_do_local_roots_nat #endif diff --git a/runtime/caml/stack.h b/runtime/caml/stack.h index 9c182ee6a88..51ff0c0be1e 100644 --- a/runtime/caml/stack.h +++ b/runtime/caml/stack.h @@ -44,9 +44,11 @@ #else #error "TARGET_power: wrong MODEL" #endif +/* FIXME: Already_scanned optimisation not supported on this branch #define Already_scanned(sp, retaddr) ((retaddr) & 1) #define Mask_already_scanned(retaddr) ((retaddr) & ~1) #define Mark_scanned(sp, retaddr) Saved_return_address(sp) = (retaddr) | 1 +*/ #endif #ifdef TARGET_s390x diff --git a/runtime/memory.c b/runtime/memory.c index a3d5a33a4ee..6813d4e8542 100644 --- a/runtime/memory.c +++ b/runtime/memory.c @@ -34,6 +34,7 @@ #include "caml/signals.h" #include "caml/memprof.h" #include "caml/eventlog.h" +#include "caml/alloc.h" int caml_huge_fallback_count = 0; /* Number of times that mmapping big pages fails and we fell back to small @@ -676,11 +677,6 @@ CAMLexport CAMLweakdef void caml_modify (value *fp, value val) } } -struct region_stack { - char* base; - struct region_stack* next; -}; - CAMLexport intnat caml_local_region_begin() { return Caml_state->local_sp; @@ -691,37 +687,98 @@ CAMLexport void caml_local_region_end(intnat reg) Caml_state->local_sp = reg; } -//#define Local_init_wsz 64 -#define Local_init_wsz (4096) -void caml_local_realloc() +CAMLexport caml_local_arenas* caml_get_local_arenas() +{ + caml_local_arenas* s = Caml_state->local_arenas; + if (s != NULL) + s->saved_sp = Caml_state->local_sp; + return s; +} + +CAMLexport void caml_set_local_arenas(caml_local_arenas* s) { - intnat new_bsize; - struct region_stack* stk; - char* stkbase; - if (Caml_state->local_top == NULL) { - new_bsize = Bsize_wsize(Local_init_wsz); + Caml_state->local_arenas = s; + if (s != NULL) { + struct caml_local_arena a = s->arenas[s->count - 1]; + Caml_state->local_sp = s->saved_sp; + Caml_state->local_top = (void*)(a.base + a.length); + Caml_state->local_limit = - a.length; } else { - CAMLassert((char*)Caml_state->local_top + Caml_state->local_limit == Caml_state->local_top->base); - new_bsize = -Caml_state->local_limit; + Caml_state->local_sp = 0; + Caml_state->local_top = NULL; + Caml_state->local_limit = 0; } - while (Caml_state->local_sp < -new_bsize) new_bsize *= 2; - stkbase = caml_stat_alloc(new_bsize + sizeof(struct region_stack)); - stk = (struct region_stack*)(stkbase + new_bsize); - memset(stkbase, 0x42, new_bsize); /* FIXME debugging only */ - stk->base = stkbase; - stk->next = Caml_state->local_top; - Caml_state->local_top = stk; - Caml_state->local_limit = -new_bsize; +} + +void caml_local_realloc() +{ + caml_local_arenas* s = caml_get_local_arenas(); + intnat i; + char* arena; + if (s == NULL) { + s = caml_stat_alloc(sizeof(*s)); + s->count = 0; + s->next_length = 0; + s->saved_sp = Caml_state->local_sp; + } + if (s->count == Max_local_arenas) + caml_fatal_error("Local allocation stack overflow - exceeded Max_local_arenas"); + + do { + if (s->next_length == 0) { + s->next_length = Init_local_arena_bsize; + } else { + /* overflow check */ + CAML_STATIC_ASSERT(((intnat)Init_local_arena_bsize << (2*Max_local_arenas)) > 0); + s->next_length *= 4; + } + /* may need to loop, if a very large allocation was requested */ + } while (s->saved_sp + s->next_length < 0); + + arena = caml_stat_alloc_noexc(s->next_length); + if (arena == NULL) + caml_fatal_error("Local allocation stack overflow - out of memory"); +#ifdef DEBUG + for (i = 0; i < s->next_length; i += sizeof(value)) { + *((header_t*)(arena + i)) = Debug_uninit_local; + } +#endif + for (i = s->saved_sp; i < 0; i += sizeof(value)) { + *((header_t*)(arena + s->next_length + i)) = Local_uninit_hd; + } + caml_gc_message(0x08, + "Growing local stack to %"ARCH_INTNAT_PRINTF_FORMAT"d kB\n", + s->next_length / 1024); + s->count++; + s->arenas[s->count-1].length = s->next_length; + s->arenas[s->count-1].base = arena; + caml_set_local_arenas(s); + CAMLassert(Caml_state->local_limit <= Caml_state->local_sp); } CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) { +#ifdef NATIVE_CODE intnat sp = Caml_state->local_sp; + header_t* hp; sp -= Bhsize_wosize(wosize); Caml_state->local_sp = sp; if (sp < Caml_state->local_limit) caml_local_realloc(); - return Val_hp((char*)Caml_state->local_top + sp); + hp = (header_t*)((char*)Caml_state->local_top + sp); + *hp = Make_header(wosize, tag, Local_unmarked); + return Val_hp(hp); +#else + if (wosize <= Max_young_wosize) { + return caml_alloc_small(wosize, tag); + } else { + /* The return value is initialised directly using Field. + This is invalid if it may create major -> minor pointers. + So, perform a minor GC to prevent this. (See caml_make_vect) */ + caml_minor_collection(); + return caml_alloc_shr(wosize, tag); + } +#endif } /* Global memory pool. diff --git a/runtime/minor_gc.c b/runtime/minor_gc.c index 9155a6fd632..b5947ef894b 100644 --- a/runtime/minor_gc.c +++ b/runtime/minor_gc.c @@ -348,6 +348,36 @@ void caml_oldify_mopup (void) if (redo) goto again; } +#ifdef DEBUG +static void verify_minor_heap() +{ + header_t* p; + struct caml_local_arena* arena = Caml_state->local_arenas ? + &Caml_state->local_arenas->arenas[Caml_state->local_arenas->count-1] : NULL; + for (p = (header_t*)Caml_state->young_ptr; + p < (header_t*)Caml_state->young_alloc_end; + p += Whsize_hp(p)) { + header_t hd = *p; + CAMLassert_young_header(hd); + if (Tag_hd(hd) < No_scan_tag) { + intnat i = 0; + if (Tag_hd(hd) == Closure_tag) + i = Start_env_closinfo(Closinfo_val(Val_hp(p))); + for (; i < Wosize_hd(hd); i++) { + value v = Field(Val_hp(p), i); + if (Is_block(v)) { + if (Is_young(v)) CAMLassert ((value)Caml_state->young_ptr < v); + if (arena) { + CAMLassert(!(arena->base <= (char*)v && + (char*)v < arena->base + arena->length)); + } + } + } + } + } +} +#endif + /* Make sure the minor heap is empty by performing a minor collection if needed. */ @@ -360,6 +390,9 @@ void caml_empty_minor_heap (void) if (Caml_state->young_ptr != Caml_state->young_alloc_end){ CAMLassert_young_header(*(header_t*)Caml_state->young_ptr); +#ifdef DEBUG + verify_minor_heap(); +#endif if (caml_minor_gc_begin_hook != NULL) (*caml_minor_gc_begin_hook) (); prev_alloc_words = caml_allocated_words; Caml_state->in_minor_collection = 1; diff --git a/runtime/roots_nat.c b/runtime/roots_nat.c index 52eb5b928e3..813d70a058f 100644 --- a/runtime/roots_nat.c +++ b/runtime/roots_nat.c @@ -242,17 +242,8 @@ void caml_register_dyn_global(void *v) { heap. */ void caml_oldify_local_roots (void) { - char * sp; - uintnat retaddr; - value * regs; - frame_descr * d; - uintnat h; intnat i, j; - int n, ofs; - unsigned short * p; value * glob; - value * root; - struct caml__roots_block *lr; link *lnk; /* The global roots */ @@ -276,82 +267,12 @@ void caml_oldify_local_roots (void) } } - /* The stack and local roots */ - sp = Caml_state->bottom_of_stack; - retaddr = Caml_state->last_return_address; - regs = Caml_state->gc_regs; - if (sp != NULL) { - while (1) { - /* Find the descriptor corresponding to the return address */ - h = Hash_retaddr(retaddr); - while(1) { - d = caml_frame_descriptors[h]; - if (d->retaddr == retaddr) break; - h = (h+1) & caml_frame_descriptors_mask; - } - if (d->frame_size != 0xFFFF) { - /* Scan the roots in this frame */ - for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { - ofs = *p; - if (ofs & 1) { - root = regs + (ofs >> 1); - } else { - root = (value *)(sp + ofs); - } - Oldify (root); - } - /* Move to next frame */ - sp += (d->frame_size & 0xFFFC); - retaddr = Saved_return_address(sp); -#ifdef Already_scanned - /* Stop here if the frame has been scanned during earlier GCs */ - if (Already_scanned(sp, retaddr)) break; - /* Mark frame as already scanned */ - Mark_scanned(sp, retaddr); -#endif - } else { - /* This marks the top of a stack chunk for an ML callback. - Skip C portion of stack and continue with next ML stack chunk. */ - struct caml_context * next_context = Callback_link(sp); - sp = next_context->bottom_of_stack; - retaddr = next_context->last_retaddr; - regs = next_context->gc_regs; - /* A null sp means no more ML stack chunks; stop here. */ - if (sp == NULL) break; - } - } - } - /* Local C roots */ - for (lr = Caml_state->local_roots; lr != NULL; lr = lr->next) { - for (i = 0; i < lr->ntables; i++){ - for (j = 0; j < lr->nitems; j++){ - root = &(lr->tables[i][j]); - Oldify (root); - } - } - } - /* Local allocations */ - { - header_t* hp = (header_t*)((char*)Caml_state->local_top + Caml_state->local_sp); - value start = Val_hp(hp), end = Val_hp((header_t*)Caml_state->local_top); - while (hp < (header_t*)Caml_state->local_top) { - header_t hd = Hd_hp(hp); - if (caml_scan_roots_hook != NULL) abort(); /* FIXME systhreads support */ - CAMLassert(Tag_hd(hd) != Infix_tag); - if (Tag_hd(hd) < No_scan_tag) { - i = 0; - if (Tag_hd(hd) == Closure_tag) - i = Start_env_closinfo(Closinfo_val(Val_hp(hp))); - for (; i < Wosize_hd(hd); i++) { - value* p = Op_hp(hp) + i; - if (Is_block(*p) && !(start <= *p && *p < end)) - Oldify(p); - } - } - hp += Whsize_hd(hd); - } - CAMLassert(hp == (header_t*)Caml_state->local_top); - } + /* Stack & local C roots */ + caml_do_local_roots_nat(NULL, &caml_oldify_one, Caml_state->bottom_of_stack, + Caml_state->last_return_address, Caml_state->gc_regs, + Caml_state->local_roots, + caml_get_local_arenas()); + /* Global C roots */ caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ @@ -445,9 +366,10 @@ void caml_do_roots (scanning_action f, int do_globals) CAML_EV_END(EV_MAJOR_ROOTS_DYNAMIC_GLOBAL); /* The stack and local roots */ CAML_EV_BEGIN(EV_MAJOR_ROOTS_LOCAL); - caml_do_local_roots_nat(f, Caml_state->bottom_of_stack, + caml_do_local_roots_nat(f, f, Caml_state->bottom_of_stack, Caml_state->last_return_address, Caml_state->gc_regs, - Caml_state->local_roots); + Caml_state->local_roots, + caml_get_local_arenas()); CAML_EV_END(EV_MAJOR_ROOTS_LOCAL); /* Global C roots */ CAML_EV_BEGIN(EV_MAJOR_ROOTS_C); @@ -467,9 +389,151 @@ void caml_do_roots (scanning_action f, int do_globals) CAML_EV_END(EV_MAJOR_ROOTS_HOOK); } -void caml_do_local_roots_nat(scanning_action f, char * bottom_of_stack, +/* Returns 1 if it visits an unmarked local block */ +static int visit(scanning_action maj, scanning_action min, + value* p) +{ + value v = *p, vblock = v; + header_t hd; + if (!Is_block(v)) + return 0; + + hd = Hd_val(vblock); + if (Tag_hd(hd) == Infix_tag) { + vblock -= Infix_offset_val(v); + hd = Hd_val(vblock); + } + + if (Color_hd(hd) == Caml_black) + return 0; + + if (Is_young(vblock)) { + if (min != NULL) min(v, p); + return 0; + } + + if (Color_hd(hd) == Local_unmarked) { + Hd_val(vblock) = With_color_hd(hd, Local_marked); + return 1; + } + + if (maj != NULL) maj(v, p); + return 0; +} + +static int get_local_ix(caml_local_arenas* loc, value v) +{ + int i; + CAMLassert(Is_block(v)); + for (i = 0; i < loc->count; i++) { + struct caml_local_arena arena = loc->arenas[i]; + if (arena.base <= (char*)v && (char*)v < arena.base + arena.length) + return i; + } + caml_fatal_error("not a local value"); +} + +static void do_local_allocations(caml_local_arenas* loc, + scanning_action maj, scanning_action min) +{ + int arena_ix; + intnat sp; + struct caml_local_arena arena; + + if (loc == NULL) return; + CAMLassert(loc->count > 0); + sp = loc->saved_sp; + arena_ix = loc->count - 1; + arena = loc->arenas[arena_ix]; + + while (sp < 0) { + header_t* hp = (header_t*)(arena.base + arena.length + sp), hd = *hp; + intnat i; + + if (hd == Local_uninit_hd) { + CAMLassert(arena_ix > 0); + arena = loc->arenas[--arena_ix]; + continue; + } + if (Color_hd(hd) != Local_marked) { + sp += Bhsize_hd(hd); + continue; + } + *hp = With_color_hd(hd, Local_scanned); + if (Tag_hd(hd) >= No_scan_tag) { + sp += Bhsize_hd(hd); + continue; + } + i = 0; + if (Tag_hd(hd) == Closure_tag) + i = Start_env_closinfo(Closinfo_val(Val_hp(hp))); + for (; i < Wosize_hd(hd); i++) { + value *p = &Field(Val_hp(hp), i); + int marked_local = visit(maj, min, p); + if (marked_local) { + int ix = get_local_ix(loc, *p); + struct caml_local_arena a = loc->arenas[ix]; + intnat newsp = (char*)p - (a.base + a.length); + if (sp <= newsp) { + /* forwards pointer, common case */ + CAMLassert(ix <= arena_ix); + } else { + /* FIXME: backwards pointer. + This should reset sp and iterate to a fixpoint */ + CAMLassert(ix >= arena_ix); + caml_fatal_error("FIXME: backwards local pointer"); + } + } + } + sp += Bhsize_hd(hd); + } + + /* clear marks */ + sp = loc->saved_sp; + arena_ix = loc->count - 1; + arena = loc->arenas[arena_ix]; +#ifdef DEBUG + { header_t* hp; + for (hp = (header_t*)arena.base; + hp < (header_t*)(arena.base + arena.length + sp); + hp++) { + *hp = Debug_free_local; + } + } +#endif + + while (sp < 0) { + header_t* hp = (header_t*)(arena.base + arena.length + sp); + if (*hp == Local_uninit_hd) { + arena = loc->arenas[--arena_ix]; +#ifdef DEBUG + for (hp = (header_t*)arena.base; + hp < (header_t*)(arena.base + arena.length + sp); + hp++) { + *hp = Debug_free_local; + } +#endif + continue; + } +#ifdef DEBUG + CAMLassert(Color_hd(*hp) != Local_marked); + if (Color_hd(*hp) == Local_unmarked) { + intnat i; + for (i = 0; i < Wosize_hd(*hp); i++) { + Field(Val_hp(hp), i) = Debug_free_local; + } + } +#endif + *hp = With_color_hd(*hp, Local_unmarked); + sp += Bhsize_hp(hp); + } +} + +void caml_do_local_roots_nat(scanning_action maj, scanning_action min, + char * bottom_of_stack, uintnat last_retaddr, value * gc_regs, - struct caml__roots_block * local_roots) + struct caml__roots_block * local_roots, + caml_local_arenas* arenas) { char * sp; uintnat retaddr; @@ -502,7 +566,7 @@ void caml_do_local_roots_nat(scanning_action f, char * bottom_of_stack, } else { root = (value *)(sp + ofs); } - f (*root, root); + visit(maj, min, root); } /* Move to next frame */ sp += (d->frame_size & 0xFFFC); @@ -527,32 +591,12 @@ void caml_do_local_roots_nat(scanning_action f, char * bottom_of_stack, for (i = 0; i < lr->ntables; i++){ for (j = 0; j < lr->nitems; j++){ root = &(lr->tables[i][j]); - f (*root, root); + visit(maj, min, root); } } } /* Local allocations */ - { - header_t* hp = (header_t*)((char*)Caml_state->local_top + Caml_state->local_sp); - value start = Val_hp(hp), end = Val_hp((header_t*)Caml_state->local_top); - while (hp < (header_t*)Caml_state->local_top) { - header_t hd = Hd_hp(hp); - if (caml_scan_roots_hook != NULL) abort(); /* FIXME systhreads support */ - CAMLassert(Tag_hd(hd) != Infix_tag); - if (Tag_hd(hd) < No_scan_tag) { - i = 0; - if (Tag_hd(hd) == Closure_tag) - i = Start_env_closinfo(Closinfo_val(Val_hp(hp))); - for (; i < Wosize_hd(hd); i++) { - value* p = Op_hp(hp) + i; - if (Is_block(*p) && !(start <= *p && *p < end)) - f(*p, p); - } - } - hp += Whsize_hd(hd); - } - CAMLassert(hp == (header_t*)Caml_state->local_top); - } + do_local_allocations(arenas, maj, min); } uintnat (*caml_stack_usage_hook)(void) = NULL; diff --git a/runtime/startup_byt.c b/runtime/startup_byt.c index a06617da67d..95b38e72033 100644 --- a/runtime/startup_byt.c +++ b/runtime/startup_byt.c @@ -450,8 +450,11 @@ CAMLexport void caml_main(char_os **argv) caml_close_channel(chan); /* this also closes fd */ caml_stat_free(trail.section); /* Ensure that the globals are in the major heap. */ - caml_oldify_one (caml_global_data, &caml_global_data); - caml_oldify_mopup (); + { + CAMLparam1(caml_global_data); + caml_minor_collection(); + CAMLdrop; + } /* Initialize system libraries */ caml_sys_init(exe_name, argv + pos); /* Load debugging info, if b>=2 */ @@ -540,8 +543,11 @@ CAMLexport value caml_startup_code_exn( /* Load the globals */ caml_global_data = caml_input_value_from_block(data, data_size); /* Ensure that the globals are in the major heap. */ - caml_oldify_one (caml_global_data, &caml_global_data); - caml_oldify_mopup (); + { + CAMLparam1(caml_global_data); + caml_minor_collection(); + CAMLdrop; + } /* Record the sections (for caml_get_section_table in meta.c) */ caml_section_table = section_table; caml_section_table_size = section_table_size; diff --git a/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference b/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference index 461abdd8e08..a8fa35a8f24 100644 --- a/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference +++ b/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference @@ -105,7 +105,6 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+34]) Texp_apply expression (test_locations.ml[19,572+21]..test_locations.ml[19,572+22]) - alloc_mode Texp_ident "Stdlib!.+" [ diff --git a/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference b/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference index e6ee1f1aceb..cce0ee765ab 100644 --- a/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference +++ b/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference @@ -105,7 +105,6 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) expression Texp_apply expression - alloc_mode Texp_ident "Stdlib!.+" [ diff --git a/testsuite/tests/typing-local/alloc.ml b/testsuite/tests/typing-local/alloc.ml index 7aa3b17a81a..85aa6df78d7 100644 --- a/testsuite/tests/typing-local/alloc.ml +++ b/testsuite/tests/typing-local/alloc.ml @@ -7,7 +7,10 @@ type smallrecord = { a : t; b : t; c : t } external opaque_local : local_ 'a -> local_ 'a = "%opaque" let ignore_local : local_ 'a -> unit = - fun x -> let _ = local_ opaque_local x in () + fun x -> + Gc.minor (); + let _ = local_ opaque_local x in + () let makesmall n = ignore_local { a = n; b = n; c = n }; @@ -234,7 +237,9 @@ let rec makemanylong n = external local_array: int -> 'a -> local_ 'a array = "caml_make_local_vect" let makeverylong n = - ignore_local (local_array 10_000 n); + (* This is many times larger than the largest allocation so far. + The local region will have to grow several times to accommodate it. *) + ignore_local (local_array 100_000 n); () (* FIXME: @@ -280,4 +285,8 @@ let () = run "longfgarray" makelongarray 42.; run "ref" makeref 42; run "verylong" makeverylong 42; - run "manylong" makemanylong 100; + run "manylong" makemanylong 100 + + +(* In debug mode, Gc.minor () checks for minor heap->local pointers *) +let () = Gc.minor () diff --git a/testsuite/tests/typing-local/lifetime.ml b/testsuite/tests/typing-local/lifetime.ml new file mode 100644 index 00000000000..a30b413f862 --- /dev/null +++ b/testsuite/tests/typing-local/lifetime.ml @@ -0,0 +1,42 @@ +(* TEST *) + +let final = ref false +let rtrue = ref true +let ev s = Printf.printf "%15s: %b\n" s !final + +let[@inline never] alloc () = + let r = ref 42 in + Gc.finalise (fun _ -> final := true) r; + ev "initial"; + Gc.full_major (); + ev "live reg"; + r + +let[@inline never] use (local_ _) = () + +let[@inline never] live_local () = + if !rtrue then begin + let g = + if !rtrue then begin + let s = local_ (Some (Some (alloc ()))) in + Gc.full_major (); + ev "live local"; + use s; + + let rec local_ f x = if x then (use s; ()) else (g (); ()) + and g () = f true; () + in + g + end else (fun () -> assert false) in + Gc.full_major (); + ev "live infix"; + g (); + end; + Gc.full_major (); + ev "dead local"; + () + +let () = + live_local (); + Gc.full_major (); + ev "after return" diff --git a/testsuite/tests/typing-local/lifetime.reference b/testsuite/tests/typing-local/lifetime.reference new file mode 100644 index 00000000000..e800fafc886 --- /dev/null +++ b/testsuite/tests/typing-local/lifetime.reference @@ -0,0 +1,6 @@ + initial: false + live reg: false + live local: false + live infix: false + dead local: true + after return: true diff --git a/testsuite/tests/typing-local/local.ml b/testsuite/tests/typing-local/local.ml index 0e650bef514..fa298dea4ac 100644 --- a/testsuite/tests/typing-local/local.ml +++ b/testsuite/tests/typing-local/local.ml @@ -976,3 +976,8 @@ Error: Signature mismatch: foo : string; The first is nonlocal and the second is not. |}] + +(* In debug mode, Gc.minor () checks for minor heap->local pointers *) +let () = Gc.minor () +[%%expect{| +|}]