From: Ralf Treinen Date: Mon, 12 May 2008 19:46:34 +0000 (+0000) Subject: Imported Upstream version 3.10.2 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~31 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=33fc0db6afb99d1a15092aa3c1faef764ebb752d;p=ocaml.git Imported Upstream version 3.10.2 --- diff --git a/Changes b/Changes index 7eee8820..0ed6e5cd 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,20 @@ +Objective Caml 3.10.2: +---------------------- + +Bug fixes: +- PR#1217 (partial) Typo in ocamldep man page +- PR#3952 (partial) ocamlopt: allocation problems on ARM +- PR#4339 (continued) ocamlopt: problems on HPPA +- PR#4455 str.mli not installed under Windows +- PR#4473 crash when accessing float array with polymorphic method +- PR#4480 runtime would not compile without gcc extensions +- PR#4481 wrong typing of exceptions with object arguments +- PR#4490 typo in error message +- Random crash on 32-bit when major_heap_increment >= 2^22 +- Big performance bug in Weak hashtables +- Small bugs in the make-package-macosx script +- Bug in typing of polymorphic variants (reported on caml-list) + Objective Caml 3.10.1: ---------------------- @@ -82,7 +99,7 @@ New features: - made configure script work on PlayStation 3 - ARM port: brought up-to-date for Debian 4.0 (Etch) - many other small changes and bugfixes in camlp4, ocamlbuild, labltk, - emacs files, + emacs files Objective Caml 3.10.0: ---------------------- @@ -2236,4 +2253,4 @@ Caml Special Light 1.06: * First public release. -$Id: Changes,v 1.168.2.7 2008/01/04 13:27:04 doligez Exp $ +$Id: Changes,v 1.168.2.13 2008/02/29 12:17:26 doligez Exp $ diff --git a/VERSION b/VERSION index e02a2ee7..0c28df08 100644 --- a/VERSION +++ b/VERSION @@ -1,6 +1,6 @@ -3.10.1 +3.10.2 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli -# $Id: VERSION,v 1.2.2.11 2008/01/11 11:17:21 doligez Exp $ +# $Id: VERSION,v 1.2.2.17 2008/02/29 12:17:26 doligez Exp $ diff --git a/asmrun/.depend b/asmrun/.depend index 3176dd55..ec447ee7 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -252,7 +252,7 @@ minor_gc.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ - ../byterun/mlvalues.h + ../byterun/mlvalues.h ../byterun/weak.h ../byterun/mlvalues.h misc.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ @@ -620,7 +620,7 @@ minor_gc.d.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ - ../byterun/mlvalues.h + ../byterun/mlvalues.h ../byterun/weak.h ../byterun/mlvalues.h misc.d.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ @@ -988,7 +988,7 @@ minor_gc.p.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ - ../byterun/mlvalues.h + ../byterun/mlvalues.h ../byterun/weak.h ../byterun/mlvalues.h misc.p.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ diff --git a/asmrun/arm.S b/asmrun/arm.S index 109e930c..da036506 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: arm.S,v 1.15 2004/01/03 12:51:18 doligez Exp $ */ +/* $Id: arm.S,v 1.15.18.1 2008/02/20 12:25:17 xleroy Exp $ */ /* Asm part of the runtime system, ARM processor */ @@ -91,11 +91,13 @@ caml_allocN: /* Record return address and desired size */ ldr alloc_limit, .Lcaml_last_return_address str lr, [alloc_limit, #0] - str r10, .Lcaml_requested_size + ldr alloc_limit, .LLcaml_requested_size + str r10, [alloc_limit, #0] /* Invoke GC */ bl .Linvoke_gc /* Try again */ - ldr r10, .Lcaml_requested_size + ldr r10, .LLcaml_requested_size + ldr r10, [r10, #0] b caml_allocN /* Shared code to invoke the GC */ @@ -323,9 +325,12 @@ caml_ml_array_bound_error: .LLtrap_handler: .word .Ltrap_handler .Lcaml_apply2: .word caml_apply2 .Lcaml_apply3: .word caml_apply3 -.Lcaml_requested_size: .word 0 +.LLcaml_requested_size: .word .Lcaml_requested_size .Lcaml_array_bound_error: .word caml_array_bound_error +.data +.Lcaml_requested_size: .word 0 + /* GC roots for callback */ .data diff --git a/asmrun/roots.c b/asmrun/roots.c index a0c61618..d35e7634 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: roots.c,v 1.41.2.1 2007/10/25 09:08:20 xleroy Exp $ */ +/* $Id: roots.c,v 1.41.2.2 2008/02/20 12:18:13 xleroy Exp $ */ /* To walk the memory roots for garbage collection */ @@ -233,7 +233,11 @@ void caml_do_local_roots(scanning_action f, char * bottom_of_stack, frame_descr * d; uintnat h; int i, j, n, ofs; +#ifdef Stack_grows_upwards + short * p; /* PR#4339: stack offsets are negative in this case */ +#else unsigned short * p; +#endif value * root; struct caml__roots_block *lr; diff --git a/boot/ocamlc b/boot/ocamlc index 63b5acdc..29b8cdeb 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 03f28d90..b5c48aa1 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 3afd66ec..2897bf2a 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index 7dcc2649..627f94f1 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typeopt.ml,v 1.10 2004/04/16 00:50:23 garrigue Exp $ *) +(* $Id: typeopt.ml,v 1.10.20.1 2008/01/18 03:54:57 garrigue Exp $ *) (* Auxiliaries for type-based optimizations, e.g. array kinds *) @@ -52,7 +52,7 @@ let maybe_pointer exp = let array_element_kind env ty = let ty = Ctype.repr (Ctype.expand_head env ty) in match ty.desc with - Tvar -> + Tvar | Tunivar -> Pgenarray | Tconstr(p, args, abbrev) -> if Path.same p Predef.path_int || Path.same p Predef.path_char then diff --git a/byterun/.depend b/byterun/.depend index 43277c13..3ce28b10 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -87,7 +87,7 @@ meta.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h minor_gc.o: minor_gc.c config.h ../config/m.h ../config/s.h \ compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h misc.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h obj.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ @@ -224,7 +224,7 @@ meta.d.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h minor_gc.d.o: minor_gc.c config.h ../config/m.h ../config/s.h \ compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h misc.d.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h obj.d.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ diff --git a/byterun/compatibility.h b/byterun/compatibility.h index 0eca2794..f005bfd0 100644 --- a/byterun/compatibility.h +++ b/byterun/compatibility.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compatibility.h,v 1.15 2006/01/27 14:33:42 doligez Exp $ */ +/* $Id: compatibility.h,v 1.15.6.1 2008/01/21 14:09:05 doligez Exp $ */ /* definitions for compatibility with old identifiers */ @@ -237,8 +237,7 @@ #define young_end caml_young_end #define young_ptr caml_young_ptr #define young_limit caml_young_limit -#define ref_table_ptr caml_ref_table_ptr -#define ref_table_limit caml_ref_table_limit +#define ref_table caml_ref_table #define minor_collection caml_minor_collection #define check_urgent_gc caml_check_urgent_gc diff --git a/byterun/finalise.c b/byterun/finalise.c index ed1e91bc..9408c9eb 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: finalise.c,v 1.19.10.1 2007/11/19 17:15:53 doligez Exp $ */ +/* $Id: finalise.c,v 1.19.10.2 2008/01/17 15:57:23 doligez Exp $ */ /* Handling of finalised values. */ @@ -85,8 +85,9 @@ void caml_final_update (void) Assert (Is_in_heap (final_table[i].val)); if (Is_white_val (final_table[i].val)){ if (Tag_val (final_table[i].val) == Forward_tag){ + value fv; Assert (final_table[i].offset == 0); - value fv = Forward_val (final_table[i].val); + fv = Forward_val (final_table[i].val); if (Is_block (fv) && (Is_young (fv) || Is_in_heap (fv)) && (Tag_val (fv) == Forward_tag || Tag_val (fv) == Lazy_tag || Tag_val (fv) == Double_tag)){ diff --git a/byterun/freelist.c b/byterun/freelist.c index de775503..91c9d7cd 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: freelist.c,v 1.17 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: freelist.c,v 1.17.10.3 2008/02/19 13:36:49 doligez Exp $ */ #include "config.h" #include "freelist.h" @@ -63,7 +63,11 @@ static void fl_check (void) size_found += Whsize_bp (cur); Assert (Is_in_heap (cur)); if (cur == fl_prev) prev_found = 1; - if (cur == caml_fl_merge) merge_found = 1; + if (cur == caml_fl_merge){ + merge_found = 1; + Assert (cur <= caml_gc_sweep_hp); + Assert (Next (cur) == NULL || Next (cur) > caml_gc_sweep_hp); + } prev = cur; cur = Next (prev); } @@ -71,6 +75,7 @@ static void fl_check (void) Assert (merge_found || caml_fl_merge == Fl_head); Assert (size_found == caml_fl_cur_size); } + #endif /* [allocate_block] is called by [caml_fl_allocate]. Given a suitable free @@ -109,7 +114,7 @@ static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur) } fl_prev = prev; return cur + Bosize_hd (h) - Bsize_wsize (wh_sz); -} +} /* [caml_fl_allocate] does not set the header of the newly allocated block. The calling function must do it before any GC function gets called. @@ -175,14 +180,9 @@ char *caml_fl_merge_block (char *bp) mlsize_t prev_wosz; caml_fl_cur_size += Whsize_hd (hd); - + #ifdef DEBUG - { - mlsize_t i; - for (i = 0; i < Wosize_hd (hd); i++){ - Field (Val_bp (bp), i) = Debug_free_major; - } - } + caml_set_fields (bp, 0, Debug_free_major); #endif prev = caml_fl_merge; cur = Next (prev); @@ -249,29 +249,26 @@ char *caml_fl_merge_block (char *bp) /* This is a heap extension. We have to insert it in the right place in the free-list. - [caml_fl_add_block] can only be called right after a call to + [caml_fl_add_blocks] can only be called right after a call to [caml_fl_allocate] that returned NULL. Most of the heap extensions are expected to be at the end of the free list. (This depends on the implementation of [malloc].) + + [bp] must point to a list of blocks chained by their field 0, + terminated by NULL, and field 1 of the first block must point to + the last block. */ -void caml_fl_add_block (char *bp) +void caml_fl_add_blocks (char *bp) { Assert (fl_last != NULL); Assert (Next (fl_last) == NULL); -#ifdef DEBUG - { - mlsize_t i; - for (i = 0; i < Wosize_bp (bp); i++){ - Field (Val_bp (bp), i) = Debug_free_major; - } - } -#endif - caml_fl_cur_size += Whsize_bp (bp); if (bp > fl_last){ Next (fl_last) = bp; - Next (bp) = NULL; + if (fl_last == caml_fl_merge && bp < caml_gc_sweep_hp){ + caml_fl_merge = (char *) Field (bp, 1); + } }else{ char *cur, *prev; @@ -282,12 +279,14 @@ void caml_fl_add_block (char *bp) cur = Next (prev); } Assert (prev < bp || prev == Fl_head); Assert (cur > bp || cur == NULL); - Next (bp) = cur; + Next (Field (bp, 1)) = cur; Next (prev) = bp; - /* When inserting a block between [caml_fl_merge] and [caml_gc_sweep_hp], + /* When inserting blocks between [caml_fl_merge] and [caml_gc_sweep_hp], we must advance [caml_fl_merge] to the new block, so that [caml_fl_merge] is always the last free-list block before [caml_gc_sweep_hp]. */ - if (prev == caml_fl_merge && bp <= caml_gc_sweep_hp) caml_fl_merge = bp; + if (prev == caml_fl_merge && bp < caml_gc_sweep_hp){ + caml_fl_merge = (char *) Field (bp, 1); + } } } diff --git a/byterun/freelist.h b/byterun/freelist.h index 518e768c..ad745b07 100644 --- a/byterun/freelist.h +++ b/byterun/freelist.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: freelist.h,v 1.12 2004/01/02 19:23:21 doligez Exp $ */ +/* $Id: freelist.h,v 1.12.20.1 2008/02/12 21:26:29 doligez Exp $ */ /* Free lists of heap blocks. */ @@ -28,7 +28,7 @@ char *caml_fl_allocate (mlsize_t); void caml_fl_init_merge (void); void caml_fl_reset (void); char *caml_fl_merge_block (char *); -void caml_fl_add_block (char *); +void caml_fl_add_blocks (char *); void caml_make_free_blocks (value *, mlsize_t, int); diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index fa5c7034..7f0a04d0 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: gc_ctrl.c,v 1.50.10.1 2007/11/20 18:27:06 doligez Exp $ */ +/* $Id: gc_ctrl.c,v 1.50.10.2 2008/02/12 13:30:16 doligez Exp $ */ #include "alloc.h" #include "compact.h" @@ -457,10 +457,6 @@ void caml_init_gc (uintnat minor_size, uintnat major_size, { uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size)); -#ifdef DEBUG - caml_gc_message (-1, "### O'Caml runtime: debug mode ###\n", 0); -#endif - caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); caml_percent_free = norm_pfree (percent_fr); diff --git a/byterun/main.c b/byterun/main.c index 6ede2d3f..71b989d3 100644 --- a/byterun/main.c +++ b/byterun/main.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: main.c,v 1.36 2004/01/08 22:28:48 doligez Exp $ */ +/* $Id: main.c,v 1.36.20.1 2008/02/12 13:30:16 doligez Exp $ */ /* Main entry point (can be overridden by a user-provided main() function that calls caml_main() later). */ @@ -28,6 +28,27 @@ CAMLextern void caml_expand_command_line (int *, char ***); int main(int argc, char **argv) { +#ifdef DEBUG + { + char *ocp; + char *cp; + int i; + + caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0); +#if 0 + caml_gc_message (-1, "### command line:", 0); + for (i = 0; i < argc; i++){ + caml_gc_message (-1, " %s", argv[i]); + } + caml_gc_message (-1, "\n", 0); + ocp = getenv ("OCAMLRUNPARAM"); + caml_gc_message (-1, "### OCAMLRUNPARAM=%s\n", ocp == NULL ? "" : ocp); + cp = getenv ("CAMLRUNPARAM"); + caml_gc_message (-1, "### CAMLRUNPARAM=%s\n", cp == NULL ? "" : cp); + caml_gc_message (-1, "### working dir: %s\n", getcwd (NULL, 0)); +#endif + } +#endif #ifdef _WIN32 /* Expand wildcards and diversions in command line */ caml_expand_command_line(&argc, &argv); diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 1f3ce458..c97e493a 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.c,v 1.58.10.2 2007/11/26 16:11:49 doligez Exp $ */ +/* $Id: major_gc.c,v 1.58.10.3 2008/01/21 14:09:05 doligez Exp $ */ #include @@ -50,11 +50,7 @@ extern char *caml_fl_merge; /* Defined in freelist.c. */ static char *markhp, *chunk, *limit; -static int gc_subphase; /* Subphase_main Subphase_weak[12] Subphase_final */ -#define Subphase_main 10 -#define Subphase_weak1 11 -#define Subphase_weak2 12 -#define Subphase_final 13 +int caml_gc_subphase; /* Subphase_{main,weak1,weak2,final} */ static value *weak_prev; #ifdef DEBUG @@ -118,7 +114,7 @@ static void start_cycle (void) caml_gc_message (0x01, "Starting new major GC cycle\n", 0); caml_darken_all_roots(); caml_gc_phase = Phase_mark; - gc_subphase = Subphase_main; + caml_gc_subphase = Subphase_main; markhp = NULL; #ifdef DEBUG ++ major_gc_counter; @@ -134,7 +130,7 @@ static void mark_slice (intnat work) mlsize_t size, i; caml_gc_message (0x40, "Marking %ld words\n", work); - caml_gc_message (0x40, "Subphase = %ld\n", gc_subphase); + caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase); gray_vals_ptr = gray_vals_cur; while (work > 0){ if (gray_vals_ptr > gray_vals){ @@ -197,11 +193,11 @@ static void mark_slice (intnat work) markhp = chunk; limit = chunk + Chunk_size (chunk); }else{ - switch (gc_subphase){ + switch (caml_gc_subphase){ case Subphase_main: { /* The main marking phase is over. Start removing weak pointers to dead values. */ - gc_subphase = Subphase_weak1; + caml_gc_subphase = Subphase_weak1; weak_prev = &caml_weak_list_head; } break; @@ -240,7 +236,7 @@ static void mark_slice (intnat work) work -= Whsize_hd (hd); }else{ /* Subphase_weak1 is done. Start removing dead weak arrays. */ - gc_subphase = Subphase_weak2; + caml_gc_subphase = Subphase_weak2; weak_prev = &caml_weak_list_head; } } @@ -264,7 +260,7 @@ static void mark_slice (intnat work) gray_vals_cur = gray_vals_ptr; caml_final_update (); gray_vals_ptr = gray_vals_cur; - gc_subphase = Subphase_final; + caml_gc_subphase = Subphase_final; } } break; diff --git a/byterun/major_gc.h b/byterun/major_gc.h index 7c493090..1bcf45f6 100644 --- a/byterun/major_gc.h +++ b/byterun/major_gc.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.h,v 1.21 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: major_gc.h,v 1.21.10.1 2008/01/21 14:09:05 doligez Exp $ */ #ifndef CAML_MAJOR_GC_H #define CAML_MAJOR_GC_H @@ -33,6 +33,7 @@ typedef struct { #define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block extern int caml_gc_phase; +extern int caml_gc_subphase; extern uintnat caml_allocated_words; extern double caml_extra_heap_resources; extern uintnat caml_dependent_size, caml_dependent_allocated; @@ -41,6 +42,10 @@ extern uintnat caml_fl_size_at_phase_change; #define Phase_mark 0 #define Phase_sweep 1 #define Phase_idle 2 +#define Subphase_main 10 +#define Subphase_weak1 11 +#define Subphase_weak2 12 +#define Subphase_final 13 #ifdef __alpha typedef int page_table_entry; diff --git a/byterun/memory.c b/byterun/memory.c index c3f4fa8b..5337b637 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: memory.c,v 1.43 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: memory.c,v 1.43.10.3 2008/02/12 21:26:29 doligez Exp $ */ #include #include @@ -27,6 +27,8 @@ #include "mlvalues.h" #include "signals.h" +extern uintnat caml_percent_free; /* major_gc.c */ + #ifdef USE_MMAP_INSTEAD_OF_MALLOC extern char * caml_aligned_mmap (asize_t size, int modulo, void ** block); extern void caml_aligned_munmap (char * addr, asize_t size); @@ -96,7 +98,7 @@ int caml_add_to_heap (char *m) page_table_entry *block, *new_page_table; asize_t new_page_low = Page (m); asize_t new_size = caml_page_high - new_page_low; - + caml_gc_message (0x08, "Growing page table to %lu entries\n", new_size); block = malloc (new_size * sizeof (page_table_entry)); if (block == NULL){ @@ -118,7 +120,7 @@ int caml_add_to_heap (char *m) page_table_entry *block, *new_page_table; asize_t new_page_high = Page (m + Chunk_size (m)); asize_t new_size = new_page_high - caml_page_low; - + caml_gc_message (0x08, "Growing page table to %lu entries\n", new_size); block = malloc (new_size * sizeof (page_table_entry)); if (block == NULL){ @@ -169,25 +171,52 @@ int caml_add_to_heap (char *m) } /* Allocate more memory from malloc for the heap. - Return a blue block of at least the requested size (in words). - The caller must insert the block into the free list. + Return a blue block of at least the requested size. + The blue block is chained to a sequence of blue blocks (through their + field 0); the last block of the chain is pointed by field 1 of the + first. There may be a fragment after the last block. + The caller must insert the blocks into the free list. The request must be less than or equal to Max_wosize. Return NULL when out of memory. */ static char *expand_heap (mlsize_t request) { - char *mem; - asize_t malloc_request; + char *mem, *hp, *prev; + asize_t over_request, malloc_request, remain; - malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (request)); + Assert (request <= Max_wosize); + over_request = request + request / 100 * caml_percent_free; + malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (over_request)); mem = caml_alloc_for_heap (malloc_request); if (mem == NULL){ caml_gc_message (0x04, "No room for growing heap\n", 0); return NULL; } - Assert (Wosize_bhsize (malloc_request) >= request); - Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Caml_blue); - + remain = malloc_request; + prev = hp = mem; + /* XXX find a way to do this with a call to caml_make_free_blocks */ + while (Wosize_bhsize (remain) > Max_wosize){ + Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue); +#ifdef DEBUG + caml_set_fields (Bp_hp (hp), 0, Debug_free_major); +#endif + hp += Bhsize_wosize (Max_wosize); + remain -= Bhsize_wosize (Max_wosize); + Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); + prev = hp; + } + if (remain > 1){ + Hd_hp (hp) = Make_header (Wosize_bhsize (remain), 0, Caml_blue); +#ifdef DEBUG + caml_set_fields (Bp_hp (hp), 0, Debug_free_major); +#endif + Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); + Field (Op_hp (hp), 0) = (value) NULL; + }else{ + Field (Op_hp (prev), 0) = (value) NULL; + if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white); + } + Assert (Wosize_hp (mem) >= request); if (caml_add_to_heap (mem) != 0){ caml_free_for_heap (mem); return NULL; @@ -267,7 +296,7 @@ CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) else caml_raise_out_of_memory (); } - caml_fl_add_block (new_block); + caml_fl_add_blocks (new_block); hp = caml_fl_allocate (wosize); } @@ -358,10 +387,10 @@ void caml_initialize (value *fp, value val) { *fp = val; if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){ - *caml_ref_table_ptr++ = fp; - if (caml_ref_table_ptr >= caml_ref_table_limit){ - caml_realloc_ref_table (); + if (caml_ref_table.ptr >= caml_ref_table.limit){ + caml_realloc_ref_table (&caml_ref_table); } + *caml_ref_table.ptr++ = fp; } } diff --git a/byterun/memory.h b/byterun/memory.h index 3723d04f..b830ba5b 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: memory.h,v 1.56 2007/02/09 13:31:15 doligez Exp $ */ +/* $Id: memory.h,v 1.56.4.1 2008/01/21 14:09:05 doligez Exp $ */ /* Allocation macros and functions */ @@ -94,11 +94,11 @@ color_t caml_allocation_color (void *hp); if (caml_gc_phase == Phase_mark) caml_darken (_old_, NULL); \ if (Is_block (val) && Is_young (val) \ && ! (Is_block (_old_) && Is_young (_old_))){ \ - *caml_ref_table_ptr++ = (fp); \ - if (caml_ref_table_ptr >= caml_ref_table_limit){ \ - CAMLassert (caml_ref_table_ptr == caml_ref_table_limit); \ - caml_realloc_ref_table (); \ + if (caml_ref_table.ptr >= caml_ref_table.limit){ \ + CAMLassert (caml_ref_table.ptr == caml_ref_table.limit); \ + caml_realloc_ref_table (&caml_ref_table); \ } \ + *caml_ref_table.ptr++ = (fp); \ } \ } \ }while(0) diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index 96904671..b262830e 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: minor_gc.c,v 1.43.10.1 2007/11/20 18:27:06 doligez Exp $ */ +/* $Id: minor_gc.c,v 1.43.10.2 2008/01/21 14:09:05 doligez Exp $ */ #include #include "config.h" @@ -26,23 +26,55 @@ #include "mlvalues.h" #include "roots.h" #include "signals.h" +#include "weak.h" asize_t caml_minor_heap_size; CAMLexport char *caml_young_start = NULL, *caml_young_end = NULL; CAMLexport char *caml_young_ptr = NULL, *caml_young_limit = NULL; -static value **ref_table = NULL, **ref_table_end, **ref_table_threshold; -CAMLexport value **caml_ref_table_ptr = NULL, **caml_ref_table_limit; -static asize_t ref_table_size, ref_table_reserve; + +CAMLexport struct caml_ref_table + caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}, + caml_weak_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; + int caml_in_minor_collection = 0; #ifdef DEBUG static unsigned long minor_gc_counter = 0; #endif +void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) +{ + value **new_table; + + tbl->size = sz; + tbl->reserve = rsv; + new_table = (value **) caml_stat_alloc ((tbl->size + tbl->reserve) + * sizeof (value *)); + if (tbl->base != NULL) caml_stat_free (tbl->base); + tbl->base = new_table; + tbl->ptr = tbl->base; + tbl->threshold = tbl->base + tbl->size; + tbl->limit = tbl->threshold; + tbl->end = tbl->base + tbl->size + tbl->reserve; +} + +static void reset_table (struct caml_ref_table *tbl) +{ + tbl->size = 0; + tbl->reserve = 0; + if (tbl->base != NULL) caml_stat_free (tbl->base); + tbl->base = tbl->ptr = tbl->threshold = tbl->limit = tbl->end = NULL; +} + +static void clear_table (struct caml_ref_table *tbl) +{ + tbl->ptr = tbl->base; + tbl->limit = tbl->threshold; +} + void caml_set_minor_heap_size (asize_t size) { char *new_heap; - value **new_table; Assert (size >= Minor_heap_min); Assert (size <= Minor_heap_max); @@ -59,16 +91,8 @@ void caml_set_minor_heap_size (asize_t size) caml_young_ptr = caml_young_end; caml_minor_heap_size = size; - ref_table_size = caml_minor_heap_size / sizeof (value) / 8; - ref_table_reserve = 256; - new_table = (value **) caml_stat_alloc ((ref_table_size + ref_table_reserve) - * sizeof (value *)); - if (ref_table != NULL) caml_stat_free (ref_table); - ref_table = new_table; - caml_ref_table_ptr = ref_table; - ref_table_threshold = ref_table + ref_table_size; - caml_ref_table_limit = ref_table_threshold; - ref_table_end = ref_table + ref_table_size + ref_table_reserve; + reset_table (&caml_ref_table); + reset_table (&caml_weak_ref_table); } static value oldify_todo_list = 0; @@ -191,16 +215,25 @@ void caml_empty_minor_heap (void) caml_in_minor_collection = 1; caml_gc_message (0x02, "<", 0); caml_oldify_local_roots(); - for (r = ref_table; r < caml_ref_table_ptr; r++){ + for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){ caml_oldify_one (**r, *r); } caml_oldify_mopup (); + for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){ + if (Is_block (**r) && Is_young (**r)){ + if (Hd_val (**r) == 0){ + **r = Field (**r, 0); + }else{ + **r = caml_weak_none; + } + } + } if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start; caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr); caml_young_ptr = caml_young_end; caml_young_limit = caml_young_start; - caml_ref_table_ptr = ref_table; - caml_ref_table_limit = ref_table_threshold; + clear_table (&caml_ref_table); + clear_table (&caml_weak_ref_table); caml_gc_message (0x02, ">", 0); caml_in_minor_collection = 0; } @@ -243,32 +276,34 @@ CAMLexport value caml_check_urgent_gc (value extra_root) CAMLreturn (extra_root); } -void caml_realloc_ref_table (void) -{ Assert (caml_ref_table_ptr == caml_ref_table_limit); - Assert (caml_ref_table_limit <= ref_table_end); - Assert (caml_ref_table_limit >= ref_table_threshold); +void caml_realloc_ref_table (struct caml_ref_table *tbl) +{ Assert (tbl->ptr == tbl->limit); + Assert (tbl->limit <= tbl->end); + Assert (tbl->limit >= tbl->threshold); - if (caml_ref_table_limit == ref_table_threshold){ + if (tbl->base == NULL){ + caml_alloc_table (tbl, caml_minor_heap_size / sizeof (value) / 8, 256); + }else if (tbl->limit == tbl->threshold){ caml_gc_message (0x08, "ref_table threshold crossed\n", 0); - caml_ref_table_limit = ref_table_end; + tbl->limit = tbl->end; caml_urge_major_slice (); }else{ /* This will almost never happen with the bytecode interpreter. */ asize_t sz; - asize_t cur_ptr = caml_ref_table_ptr - ref_table; + asize_t cur_ptr = tbl->ptr - tbl->base; Assert (caml_force_major_slice); - ref_table_size *= 2; - sz = (ref_table_size + ref_table_reserve) * sizeof (value *); + tbl->size *= 2; + sz = (tbl->size + tbl->reserve) * sizeof (value *); caml_gc_message (0x08, "Growing ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", (intnat) sz/1024); - ref_table = (value **) realloc ((char *) ref_table, sz); - if (ref_table == NULL){ + tbl->base = (value **) realloc ((char *) tbl->base, sz); + if (tbl->base == NULL){ caml_fatal_error ("Fatal error: ref_table overflow\n"); } - ref_table_end = ref_table + ref_table_size + ref_table_reserve; - ref_table_threshold = ref_table + ref_table_size; - caml_ref_table_ptr = ref_table + cur_ptr; - caml_ref_table_limit = ref_table_end; + tbl->end = tbl->base + tbl->size + tbl->reserve; + tbl->threshold = tbl->base + tbl->size; + tbl->ptr = tbl->base + cur_ptr; + tbl->limit = tbl->end; } } diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h index 380b38ef..dc1f12bb 100644 --- a/byterun/minor_gc.h +++ b/byterun/minor_gc.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: minor_gc.h,v 1.17 2003/12/31 14:20:37 doligez Exp $ */ +/* $Id: minor_gc.h,v 1.17.20.1 2008/01/21 14:09:05 doligez Exp $ */ #ifndef CAML_MINOR_GC_H #define CAML_MINOR_GC_H @@ -21,10 +21,20 @@ CAMLextern char *caml_young_start, *caml_young_ptr; CAMLextern char *caml_young_end, *caml_young_limit; -CAMLextern value **caml_ref_table_ptr, **caml_ref_table_limit; extern asize_t caml_minor_heap_size; extern int caml_in_minor_collection; +struct caml_ref_table { + value **base; + value **end; + value **threshold; + value **ptr; + value **limit; + asize_t size; + asize_t reserve; +}; +CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table; + #define Is_young(val) \ (Assert (Is_block (val)), \ (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) @@ -33,7 +43,8 @@ extern void caml_set_minor_heap_size (asize_t); extern void caml_empty_minor_heap (void); CAMLextern void caml_minor_collection (void); CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */ -extern void caml_realloc_ref_table (void); +extern void caml_realloc_ref_table (struct caml_ref_table *); +extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t); extern void caml_oldify_one (value, value *); extern void caml_oldify_mopup (void); diff --git a/byterun/misc.c b/byterun/misc.c index 68c96068..8e937a2a 100644 --- a/byterun/misc.c +++ b/byterun/misc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: misc.c,v 1.28 2005/10/18 14:03:43 xleroy Exp $ */ +/* $Id: misc.c,v 1.28.10.1 2008/02/12 13:30:16 doligez Exp $ */ #include #include "config.h" @@ -29,6 +29,14 @@ int caml_failed_assert (char * expr, char * file, int line) return 1; /* not reached */ } +void caml_set_fields (char *bp, unsigned long start, unsigned long filler) +{ + mlsize_t i; + for (i = start; i < Wosize_bp (bp); i++){ + Field (Val_bp (bp), i) = (value) filler; + } +} + #endif /* DEBUG */ uintnat caml_verb_gc = 0; @@ -54,7 +62,7 @@ CAMLexport void caml_fatal_error_arg (char *fmt, char *arg) } CAMLexport void caml_fatal_error_arg2 (char *fmt1, char *arg1, - char *fmt2, char *arg2) + char *fmt2, char *arg2) { fprintf (stderr, fmt1, arg1); fprintf (stderr, fmt2, arg2); diff --git a/byterun/misc.h b/byterun/misc.h index 2248deac..aeb7b3b1 100644 --- a/byterun/misc.h +++ b/byterun/misc.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: misc.h,v 1.31 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: misc.h,v 1.31.10.1 2008/02/12 13:30:16 doligez Exp $ */ /* Miscellaneous macros and variables. */ @@ -132,6 +132,8 @@ char *caml_aligned_malloc (asize_t, int, void **); #define Debug_filler_align Debug_tag (0x85) #define Debug_uninit_stat 0xD7 + +extern void caml_set_fields (char *, unsigned long, unsigned long); #endif /* DEBUG */ diff --git a/byterun/obj.c b/byterun/obj.c index 2af63fea..f846363a 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: obj.c,v 1.39 2005/01/04 16:29:33 doligez Exp $ */ +/* $Id: obj.c,v 1.39.12.2 2008/01/29 13:14:57 doligez Exp $ */ /* Operations on objects */ diff --git a/byterun/weak.c b/byterun/weak.c index 8f4377a9..19252300 100644 --- a/byterun/weak.c +++ b/byterun/weak.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: weak.c,v 1.25 2006/01/04 16:55:49 doligez Exp $ */ +/* $Id: weak.c,v 1.25.6.1 2008/01/21 14:09:05 doligez Exp $ */ /* Operations on weak arrays */ @@ -45,6 +45,24 @@ CAMLprim value caml_weak_create (value len) #define None_val (Val_int(0)) #define Some_tag 0 +static void do_set (value ar, mlsize_t offset, value v) +{ + if (Is_block (v) && Is_young (v)){ + /* modified version of Modify */ + value old = Field (ar, offset); + Field (ar, offset) = v; + if (!(Is_block (old) && Is_young (old))){ + if (caml_weak_ref_table.ptr >= caml_weak_ref_table.limit){ + CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.limit); + caml_realloc_ref_table (&caml_weak_ref_table); + } + *caml_weak_ref_table.ptr++ = &Field (ar, offset); + } + }else{ + Field (ar, offset) = v; + } +} + CAMLprim value caml_weak_set (value ar, value n, value el) { mlsize_t offset = Long_val (n) + 1; @@ -52,15 +70,11 @@ CAMLprim value caml_weak_set (value ar, value n, value el) if (offset < 1 || offset >= Wosize_val (ar)){ caml_invalid_argument ("Weak.set"); } - Field (ar, offset) = caml_weak_none; if (el != None_val){ - value v; Assert (Wosize_val (el) == 1); - v = Field (el, 0); - if (Is_block (v) && (Is_young (v) || Is_in_heap (v))){ - Modify (&Field (ar, offset), v); - }else{ - Field (ar, offset) = v; - } + Assert (Wosize_val (el) == 1); + do_set (ar, offset, Field (el, 0)); + }else{ + Field (ar, offset) = caml_weak_none; } return Val_unit; } @@ -141,3 +155,39 @@ CAMLprim value caml_weak_check (value ar, value n) } return Val_bool (Field (ar, offset) != caml_weak_none); } + +CAMLprim value caml_weak_blit (value ars, value ofs, + value ard, value ofd, value len) +{ + mlsize_t offset_s = Long_val (ofs) + 1; + mlsize_t offset_d = Long_val (ofd) + 1; + mlsize_t length = Long_val (len); + long i; + Assert (Is_in_heap (ars)); + Assert (Is_in_heap (ard)); + if (offset_s < 1 || offset_s + length > Wosize_val (ars)){ + caml_invalid_argument ("Weak.blit"); + } + if (offset_d < 1 || offset_d + length > Wosize_val (ard)){ + caml_invalid_argument ("Weak.blit"); + } + if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){ + for (i = 0; i < length; i++){ + value v = Field (ars, offset_s + i); + if (v != caml_weak_none && Is_block (v) && Is_in_heap (v) + && Is_white_val (v)){ + Field (ars, offset_s + i) = caml_weak_none; + } + } + } + if (offset_d < offset_s){ + for (i = 0; i < length; i++){ + do_set (ard, offset_d + i, Field (ars, offset_s + i)); + } + }else{ + for (i = length - 1; i >= 0; i--){ + do_set (ard, offset_d + i, Field (ars, offset_s + i)); + } + } + return Val_unit; +} diff --git a/debugger/.depend b/debugger/.depend index 328b77bd..f56903a3 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -119,12 +119,12 @@ main.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi time_travel.cmi \ show_information.cmi question.cmi program_management.cmi primitives.cmi \ parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \ ../typing/env.cmi debugger_config.cmi ../utils/config.cmi \ - command_line.cmi checkpoints.cmi + command_line.cmi ../utils/clflags.cmi checkpoints.cmi main.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx time_travel.cmx \ show_information.cmx question.cmx program_management.cmx primitives.cmx \ parameters.cmx ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \ ../typing/env.cmx debugger_config.cmx ../utils/config.cmx \ - command_line.cmx checkpoints.cmx + command_line.cmx ../utils/clflags.cmx checkpoints.cmx parameters.cmo: primitives.cmi ../utils/misc.cmi envaux.cmi \ ../utils/config.cmi parameters.cmi parameters.cmx: primitives.cmx ../utils/misc.cmx envaux.cmx \ diff --git a/man/ocamldep.m b/man/ocamldep.m index 4fa557bd..7b24082a 100644 --- a/man/ocamldep.m +++ b/man/ocamldep.m @@ -50,7 +50,7 @@ compilation unit Bar, a dependency on that unit's interface bar.cmi is generated only if the source for bar is found in the current directory or in one of the directories specified with .BR -I . -Otherwise, Bar is assumed to be a module form the standard library, +Otherwise, Bar is assumed to be a module from the standard library, and no dependencies are generated. For programs that span multiple directories, it is recommended to pass .BR ocamldep (1) diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend index 97fd3415..32bfc323 100644 --- a/otherlibs/graph/.depend +++ b/otherlibs/graph/.depend @@ -1,4 +1,5 @@ color.o: color.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -7,6 +8,7 @@ color.o: color.c libgraph.h \ ../../byterun/misc.h ../../byterun/compatibility.h \ ../../byterun/config.h draw.o: draw.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -17,6 +19,7 @@ draw.o: draw.c libgraph.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/mlvalues.h dump_img.o: dump_img.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -32,6 +35,7 @@ dump_img.o: dump_img.c libgraph.h \ ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ ../../byterun/misc.h ../../byterun/mlvalues.h events.o: events.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -44,6 +48,7 @@ events.o: events.c libgraph.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/mlvalues.h fill.o: fill.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -57,6 +62,7 @@ fill.o: fill.c libgraph.h \ ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ ../../byterun/misc.h ../../byterun/mlvalues.h image.o: image.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -68,6 +74,7 @@ image.o: image.c libgraph.h \ ../../byterun/mlvalues.h ../../byterun/custom.h \ ../../byterun/compatibility.h ../../byterun/mlvalues.h make_img.o: make_img.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -81,6 +88,7 @@ make_img.o: make_img.c libgraph.h \ ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ ../../byterun/misc.h ../../byterun/mlvalues.h open.o: open.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -99,6 +107,7 @@ open.o: open.c libgraph.h \ ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ ../../byterun/misc.h ../../byterun/mlvalues.h point_col.o: point_col.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -107,6 +116,7 @@ point_col.o: point_col.c libgraph.h \ ../../byterun/misc.h ../../byterun/compatibility.h \ ../../byterun/config.h sound.o: sound.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -115,6 +125,7 @@ sound.o: sound.c libgraph.h \ ../../byterun/misc.h ../../byterun/compatibility.h \ ../../byterun/config.h subwindow.o: subwindow.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ @@ -123,6 +134,7 @@ subwindow.o: subwindow.c libgraph.h \ ../../byterun/misc.h ../../byterun/compatibility.h \ ../../byterun/config.h text.o: text.c libgraph.h \ + \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt index 1fce47ca..f3eec32d 100644 --- a/otherlibs/str/Makefile.nt +++ b/otherlibs/str/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.15 2007/01/29 12:11:16 xleroy Exp $ +# $Id: Makefile.nt,v 1.15.4.1 2008/01/18 15:27:36 doligez Exp $ # Makefile for the str library @@ -54,7 +54,7 @@ clean: partialclean install: cp dllstr.dll $(STUBLIBDIR)/dllstr.dll cp libstr.$(A) $(LIBDIR)/libstr.$(A) - cp str.cma str.cmi $(LIBDIR) + cp str.cma str.cmi str.mli $(LIBDIR) installopt: cp str.cmx str.cmxa str.$(A) $(LIBDIR) diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index 37a41092..e1a829fa 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -22,21 +22,19 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/sys.h \ ../../byterun/misc.h condition.cmi: mutex.cmi -thread.cmi: unix.cmi -threadUnix.cmi: unix.cmi +thread.cmi: unix.cmo +threadUnix.cmi: unix.cmo condition.cmo: thread.cmi mutex.cmi condition.cmi condition.cmx: thread.cmx mutex.cmx condition.cmi event.cmo: mutex.cmi condition.cmi event.cmi event.cmx: mutex.cmx condition.cmx event.cmi -marshal.cmo: pervasives.cmi marshal.cmi -marshal.cmx: pervasives.cmx marshal.cmi +marshal.cmo: pervasives.cmo +marshal.cmx: pervasives.cmx mutex.cmo: thread.cmi mutex.cmi mutex.cmx: thread.cmx mutex.cmi -pervasives.cmo: unix.cmi pervasives.cmi -pervasives.cmx: unix.cmx pervasives.cmi -thread.cmo: unix.cmi thread.cmi +pervasives.cmo: unix.cmo +pervasives.cmx: unix.cmx +thread.cmo: unix.cmo thread.cmi thread.cmx: unix.cmx thread.cmi -threadUnix.cmo: unix.cmi thread.cmi threadUnix.cmi +threadUnix.cmo: unix.cmo thread.cmi threadUnix.cmi threadUnix.cmx: unix.cmx thread.cmx threadUnix.cmi -unix.cmo: unix.cmi -unix.cmx: unix.cmi diff --git a/stdlib/gc.mli b/stdlib/gc.mli index 373f8ac0..7dfbac1f 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: gc.mli,v 1.42 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: gc.mli,v 1.42.10.1 2008/02/12 13:30:16 doligez Exp $ *) (** Memory management control and statistics; finalised values. *) @@ -86,7 +86,7 @@ type control = mutable major_heap_increment : int; (** The minimum number of words to add to the - major heap when increasing it. Default: 62k. *) + major heap when increasing it. Default: 60k. *) mutable space_overhead : int; (** The major GC speed is computed from this parameter. diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml index 8425db7f..96566771 100644 --- a/stdlib/lazy.ml +++ b/stdlib/lazy.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: lazy.ml,v 1.11 2004/01/01 16:42:40 doligez Exp $ *) +(* $Id: lazy.ml,v 1.11.20.2 2008/01/29 13:14:57 doligez Exp $ *) (* Module [Lazy]: deferred computations *) diff --git a/stdlib/obj.ml b/stdlib/obj.ml index 465642e2..c654c197 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: obj.ml,v 1.23 2004/01/01 16:42:40 doligez Exp $ *) +(* $Id: obj.ml,v 1.23.20.2 2008/01/29 13:14:57 doligez Exp $ *) (* Operations on internal representations of values *) diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 57425f13..d372c97d 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: obj.mli,v 1.29 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: obj.mli,v 1.29.10.2 2008/01/29 13:14:57 doligez Exp $ *) (** Operations on internal representations of values. diff --git a/stdlib/weak.ml b/stdlib/weak.ml index 0ad9a022..1661fe62 100644 --- a/stdlib/weak.ml +++ b/stdlib/weak.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: weak.ml,v 1.14 2007/02/16 16:05:36 doligez Exp $ *) +(* $Id: weak.ml,v 1.14.2.2 2008/01/29 13:14:33 doligez Exp $ *) (** Weak array operations *) @@ -26,6 +26,8 @@ external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";; external get: 'a t -> int -> 'a option = "caml_weak_get";; external get_copy: 'a t -> int -> 'a option = "caml_weak_get_copy";; external check: 'a t -> int -> bool = "caml_weak_check";; +external blit: 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit";; +(* blit: src srcoff dst dstoff len *) let fill ar ofs len x = if ofs < 0 || len < 0 || ofs + len > length ar @@ -37,23 +39,6 @@ let fill ar ofs len x = end ;; -let blit ar1 of1 ar2 of2 len = - if of1 < 0 || of1 + len > length ar1 || of2 < 0 || of2 + len > length ar2 - then raise (Invalid_argument "Weak.blit") - else begin - if of2 > of1 then begin - for i = 0 to len - 1 do - set ar2 (of2 + i) (get ar1 (of1 + i)) - done - end else begin - for i = len - 1 downto 0 do - set ar2 (of2 + i) (get ar1 (of1 + i)) - done - end - end -;; - - (** Weak hash tables *) module type S = sig @@ -83,27 +68,35 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct type t = { mutable table : data weak_t array; - mutable totsize : int; (* sum of the bucket sizes *) - mutable limit : int; (* max ratio totsize/table length *) + mutable hashes : int array array; + mutable limit : int; (* bucket size limit *) + mutable oversize : int; (* number of oversize buckets *) + mutable rover : int; (* for internal bookkeeping *) };; - let get_index t d = (H.hash d land max_int) mod (Array.length t.table);; + let get_index t h = (h land max_int) mod (Array.length t.table);; + + let limit = 7;; + let over_limit = 2;; let create sz = let sz = if sz < 7 then 7 else sz in let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in { table = Array.create sz emptybucket; - totsize = 0; - limit = 3; + hashes = Array.create sz [| |]; + limit = limit; + oversize = 0; + rover = 0; };; let clear t = for i = 0 to Array.length t.table - 1 do t.table.(i) <- emptybucket; + t.hashes.(i) <- [| |]; done; - t.totsize <- 0; - t.limit <- 3; + t.limit <- limit; + t.oversize <- 0; ;; let fold f t init = @@ -126,85 +119,155 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct Array.iter (iter_bucket 0) t.table ;; - let count t = - let rec count_bucket i b accu = - if i >= length b then accu else - count_bucket (i+1) b (accu + (if check b i then 1 else 0)) + let iter_weak f t = + let rec iter_bucket i j b = + if i >= length b then () else + match check b i with + | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b + | false -> iter_bucket (i+1) j b in + Array.iteri (iter_bucket 0) t.table + ;; + + let rec count_bucket i b accu = + if i >= length b then accu else + count_bucket (i+1) b (accu + (if check b i then 1 else 0)) + ;; + + let count t = Array.fold_right (count_bucket 0) t.table 0 ;; - let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1);; + let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length;; + let prev_sz n = ((n - 3) * 2 + 2) / 3;; + + let test_shrink_bucket t = + let bucket = t.table.(t.rover) in + let hbucket = t.hashes.(t.rover) in + let len = length bucket in + let prev_len = prev_sz len in + let live = count_bucket 0 bucket 0 in + if live <= prev_len then begin + let rec loop i j = + if j >= prev_len then begin + if check bucket i then loop (i + 1) j + else if check bucket j then begin + blit bucket j bucket i 1; + hbucket.(i) <- hbucket.(j); + loop (i + 1) (j - 1); + end else loop i (j - 1); + end; + in + loop 0 (length bucket - 1); + if prev_len = 0 then begin + t.table.(t.rover) <- emptybucket; + t.hashes.(t.rover) <- [| |]; + end else begin + Obj.truncate (Obj.repr bucket) (prev_len + 1); + Obj.truncate (Obj.repr hbucket) prev_len; + end; + if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; + end; + t.rover <- (t.rover + 1) mod (Array.length t.table); + ;; let rec resize t = let oldlen = Array.length t.table in let newlen = next_sz oldlen in if newlen > oldlen then begin let newt = create newlen in - newt.limit <- t.limit + 100; (* prevent resizing of newt *) - fold (fun d () -> add newt d) t (); - (* assert Array.length newt.table = newlen; *) + let add_weak ob oh oi = + let setter nb ni _ = blit ob oi nb ni 1 in + let h = oh.(oi) in + add_aux newt setter None h (get_index newt h); + in + iter_weak add_weak t; t.table <- newt.table; - (* t.limit <- t.limit + 2; -- performance bug *) + t.hashes <- newt.hashes; + t.limit <- newt.limit; + t.oversize <- newt.oversize; + t.rover <- t.rover mod Array.length newt.table; + end else begin + t.limit <- max_int; (* maximum size already reached *) + t.oversize <- 0; end - and add_aux t d index = + and add_aux t setter d h index = let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = if i >= sz then begin - let newsz = min (sz + 3) (Sys.max_array_length - 1) in - if newsz <= sz then failwith "Weak.Make : hash bucket cannot grow more"; + let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in + if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more"; let newbucket = weak_create newsz in + let newhashes = Array.make newsz 0 in blit bucket 0 newbucket 0 sz; - set newbucket i (Some d); + Array.blit hashes 0 newhashes 0 sz; + setter newbucket sz d; + newhashes.(sz) <- h; t.table.(index) <- newbucket; - t.totsize <- t.totsize + (newsz - sz); - if t.totsize > t.limit * Array.length t.table then resize t; + t.hashes.(index) <- newhashes; + if sz <= t.limit && newsz > t.limit then begin + t.oversize <- t.oversize + 1; + for i = 0 to over_limit do test_shrink_bucket t done; + end; + if t.oversize > Array.length t.table / over_limit then resize t; + end else if check bucket i then begin + loop (i + 1) end else begin - if check bucket i - then loop (i+1) - else set bucket i (Some d) - end + setter bucket i d; + hashes.(i) <- h; + end; in loop 0; + ;; - and add t d = add_aux t d (get_index t d) + let add t d = + let h = H.hash d in + add_aux t set (Some d) h (get_index t h); ;; let find_or t d ifnotfound = - let index = get_index t d in + let h = H.hash d in + let index = get_index t h in let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = - if i >= sz then ifnotfound index - else begin + if i >= sz then ifnotfound h index + else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> begin match get bucket i with | Some v -> v - | None -> loop (i+1) + | None -> loop (i + 1) end - | _ -> loop (i+1) - end + | _ -> loop (i + 1) + end else loop (i + 1) in loop 0 ;; - let merge t d = find_or t d (fun index -> add_aux t d index; d);; + let merge t d = + find_or t d (fun h index -> add_aux t set (Some d) h index; d) + ;; - let find t d = find_or t d (fun index -> raise Not_found);; + let find t d = find_or t d (fun h index -> raise Not_found);; let find_shadow t d iffound ifnotfound = - let index = get_index t d in + let h = H.hash d in + let index = get_index t h in let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = - if i >= sz then ifnotfound else begin + if i >= sz then ifnotfound + else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> iffound bucket i - | _ -> loop (i+1) - end + | _ -> loop (i + 1) + end else loop (i + 1) in loop 0 ;; @@ -214,20 +277,22 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct let mem t d = find_shadow t d (fun w i -> true) false;; let find_all t d = - let index = get_index t d in + let h = H.hash d in + let index = get_index t h in let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i accu = if i >= sz then accu - else begin + else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> begin match get bucket i with - | Some v -> loop (i+1) (v::accu) - | None -> loop (i+1) accu + | Some v -> loop (i + 1) (v :: accu) + | None -> loop (i + 1) accu end - | _ -> loop (i+1) accu - end + | _ -> loop (i + 1) accu + end else loop (i + 1) accu in loop 0 [] ;; diff --git a/tools/make-package-macosx b/tools/make-package-macosx index 29672d85..80a0bb89 100755 --- a/tools/make-package-macosx +++ b/tools/make-package-macosx @@ -12,14 +12,14 @@ # # ######################################################################### -# $Id: make-package-macosx,v 1.13.4.1 2007/12/19 14:14:06 doligez Exp $ +# $Id: make-package-macosx,v 1.13.4.3 2008/01/25 14:00:21 doligez Exp $ cd package-macosx rm -rf ocaml.pkg ocaml-rw.dmg VERSION=`head -1 ../VERSION` -VERSION_MAJOR=`sed -n -e '1s/^\([0-9]*\)\..*/\1/p' ../VERSION -VERSION_MINOR=`sed -n -e '1s/^[0-9]*\.\([0-9]*\)[.+].*/\1/p' ../VERSION +VERSION_MAJOR=`sed -n -e '1s/^\([0-9]*\)\..*/\1/p' ../VERSION` +VERSION_MINOR=`sed -n -e '1s/^[0-9]*\.\([0-9]*\)[.+].*/\1/p' ../VERSION` # Worked in 10.2: @@ -101,7 +101,7 @@ mkdir -p resources # stop here -> | cat >resources/ReadMe.txt <&2 + echo "Unable to mount the disk image as \"/Volumes/$volname\"" >&2 exit 3 fi -open "/Volumes/Objective Caml" +open "/Volumes/$volname" +sleep 2 hdiutil detach $name rm -rf "ocaml-${VERSION}.dmg" diff --git a/typing/ctype.ml b/typing/ctype.ml index 5c210f2f..ed96e6db 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ctype.ml,v 1.205.2.3 2007/06/08 08:03:15 garrigue Exp $ *) +(* $Id: ctype.ml,v 1.205.2.5 2008/02/12 04:49:25 garrigue Exp $ *) (* Operations on core types *) @@ -1958,6 +1958,10 @@ let moregen_occur env level ty = occur_univar env ty; update_level env level ty +let may_instantiate inst_nongen t1 = + if inst_nongen then t1.level <> generic_level - 1 + else t1.level = generic_level + let rec moregen inst_nongen type_pairs env t1 t2 = if t1 == t2 then () else let t1 = repr t1 in @@ -1968,8 +1972,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = match (t1.desc, t2.desc) with (Tunivar, Tunivar) -> unify_univar t1 t2 !univar_pairs - | (Tvar, _) when if inst_nongen then t1.level <> generic_level - 1 - else t1.level = generic_level -> + | (Tvar, _) when may_instantiate inst_nongen t1 -> moregen_occur env t1.level t2; occur env t1 t2; link_type t1 t2 @@ -1986,8 +1989,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = with Not_found -> TypePairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with - (Tvar, _) when if inst_nongen then t1'.level <> generic_level - 1 - else t1'.level = generic_level -> + (Tvar, _) when may_instantiate inst_nongen t1 -> moregen_occur env t1'.level t2; link_type t1' t2 | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 @@ -2049,33 +2051,36 @@ and moregen_kind k1 k2 = and moregen_row inst_nongen type_pairs env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in + let rm1 = repr row1.row_more and rm2 = repr row2.row_more in + if rm1 == rm2 then () else + let may_inst = rm1.desc = Tvar && may_instantiate inst_nongen rm1 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in let r1, r2 = if row2.row_closed then - filter_row_fields true r1, filter_row_fields false r2 + filter_row_fields may_inst r1, filter_row_fields false r2 else r1, r2 in if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> []) then raise (Unify []); - let rm1 = repr row1.row_more and rm2 = repr row2.row_more in - let univ = - match rm1.desc, rm2.desc with - Tunivar, Tunivar -> - unify_univar rm1 rm2 !univar_pairs; - true - | Tunivar, _ | _, Tunivar -> - raise (Unify []) - | _ -> - if not (static_row row2) then moregen_occur env rm1.level rm2; - let ext = - if r2 = [] then rm2 else - let row_ext = {row2 with row_fields = r2} in - iter_row (moregen_occur env rm1.level) row_ext; - newty2 rm1.level (Tvariant row_ext) - in - if ext != rm1 then link_type rm1 ext; - false - in + begin match rm1.desc, rm2.desc with + Tunivar, Tunivar -> + unify_univar rm1 rm2 !univar_pairs + | Tunivar, _ | _, Tunivar -> + raise (Unify []) + | _ when static_row row1 -> () + | _ when may_inst -> + if not (static_row row2) then moregen_occur env rm1.level rm2; + let ext = + if r2 = [] then rm2 else + let row_ext = {row2 with row_fields = r2} in + iter_row (moregen_occur env rm1.level) row_ext; + newty2 rm1.level (Tvariant row_ext) + in + link_type rm1 ext + | Tconstr _, Tconstr _ -> + moregen inst_nongen type_pairs env rm1 rm2 + | _ -> raise (Unify []) + end; List.iter (fun (l,f1,f2) -> let f1 = row_field_repr f1 and f2 = row_field_repr f2 in @@ -2084,7 +2089,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 = Rpresent(Some t1), Rpresent(Some t2) -> moregen inst_nongen type_pairs env t1 t2 | Rpresent None, Rpresent None -> () - | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ -> + | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst -> set_row_field e1 f2; List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) -> @@ -2100,9 +2105,9 @@ and moregen_row inst_nongen type_pairs env row1 row2 = | [] -> if tl1 <> [] then raise (Unify []) end - | Reither(true, [], _, e1), Rpresent None when not univ -> + | Reither(true, [], _, e1), Rpresent None when may_inst -> set_row_field e1 f2 - | Reither(_, _, _, e1), Rabsent when not univ -> + | Reither(_, _, _, e1), Rabsent when may_inst -> set_row_field e1 f2 | Rabsent, Rabsent -> () | _ -> raise (Unify [])) diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 06bb7f2d..6c39fc8b 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typeclass.ml,v 1.89.6.2 2007/10/29 06:56:27 garrigue Exp $ *) +(* $Id: typeclass.ml,v 1.89.6.3 2008/01/28 13:26:48 doligez Exp $ *) open Misc open Parsetree @@ -1476,16 +1476,16 @@ let report_error ppf = function "This pattern cannot match self: it only matches values of type" Printtyp.type_expr ty | Unbound_class cl -> - fprintf ppf "Unbound class@ %a" + fprintf ppf "@[Unbound class@ %a@]" Printtyp.longident cl | Unbound_class_2 cl -> - fprintf ppf "The class@ %a@ is not yet completely defined" + fprintf ppf "@[The class@ %a@ is not yet completely defined@]" Printtyp.longident cl | Unbound_class_type cl -> - fprintf ppf "Unbound class type@ %a" + fprintf ppf "@[Unbound class type@ %a@]" Printtyp.longident cl | Unbound_class_type_2 cl -> - fprintf ppf "The class type@ %a@ is not yet completely defined" + fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" Printtyp.longident cl | Abbrev_type_clash (abbrev, actual, expected) -> (* XXX Afficher une trace ? *) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 33583af5..0e4072b9 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -386,8 +386,12 @@ and transl_fields env policy = function [] -> newty Tnil - | {pfield_desc = Pfield_var}::_ -> - if policy = Univars then new_pre_univar () else newvar () + | ({pfield_desc = Pfield_var} as pf)::_ -> + begin match policy with + Fixed -> raise (Error (pf.pfield_loc, Unbound_type_variable "..")) + | Extensible -> newvar () + | Univars -> new_pre_univar () + end | {pfield_desc = Pfield(s, e)}::l -> let ty1 = transl_type env policy e in let ty2 = transl_fields env policy l in