+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:
----------------------
- 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:
----------------------
* 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 $
-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 $
../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 \
../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 \
../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 \
/* */
/***********************************************************************/
-/* $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 */
/* 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 */
.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
/* */
/***********************************************************************/
-/* $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 */
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;
(* *)
(***********************************************************************)
-(* $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 *)
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
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 \
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 \
/* */
/***********************************************************************/
-/* $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 */
#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
/* */
/***********************************************************************/
-/* $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. */
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)){
/* */
/***********************************************************************/
-/* $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"
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);
}
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
}
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.
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);
/* 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;
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);
+ }
}
}
/* */
/***********************************************************************/
-/* $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. */
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);
/* */
/***********************************************************************/
-/* $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"
{
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);
/* */
/***********************************************************************/
-/* $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). */
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);
/* */
/***********************************************************************/
-/* $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 <limits.h>
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
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;
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){
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;
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;
}
}
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;
/* */
/***********************************************************************/
-/* $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
#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;
#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;
/* */
/***********************************************************************/
-/* $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 <stdlib.h>
#include <string.h>
#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);
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){
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){
}
/* 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;
else
caml_raise_out_of_memory ();
}
- caml_fl_add_block (new_block);
+ caml_fl_add_blocks (new_block);
hp = caml_fl_allocate (wosize);
}
{
*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;
}
}
/* */
/***********************************************************************/
-/* $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 */
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)
/* */
/***********************************************************************/
-/* $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 <string.h>
#include "config.h"
#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);
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;
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;
}
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;
}
}
/* */
/***********************************************************************/
-/* $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
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)
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);
/* */
/***********************************************************************/
-/* $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 <stdio.h>
#include "config.h"
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;
}
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);
/* */
/***********************************************************************/
-/* $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. */
#define Debug_filler_align Debug_tag (0x85)
#define Debug_uninit_stat 0xD7
+
+extern void caml_set_fields (char *, unsigned long, unsigned long);
#endif /* DEBUG */
/* */
/***********************************************************************/
-/* $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 */
/* */
/***********************************************************************/
-/* $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 */
#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;
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;
}
}
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;
+}
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 \
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)
color.o: color.c libgraph.h \
+ \
\
\
../../byterun/mlvalues.h ../../byterun/compatibility.h \
../../byterun/misc.h ../../byterun/compatibility.h \
../../byterun/config.h
draw.o: draw.c libgraph.h \
+ \
\
\
../../byterun/mlvalues.h ../../byterun/compatibility.h \
../../byterun/compatibility.h ../../byterun/misc.h \
../../byterun/mlvalues.h
dump_img.o: dump_img.c libgraph.h \
+ \
\
\
../../byterun/mlvalues.h ../../byterun/compatibility.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 \
../../byterun/compatibility.h ../../byterun/misc.h \
../../byterun/mlvalues.h
fill.o: fill.c libgraph.h \
+ \
\
\
../../byterun/mlvalues.h ../../byterun/compatibility.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 \
../../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 \
../../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 \
../../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 \
../../byterun/misc.h ../../byterun/compatibility.h \
../../byterun/config.h
sound.o: sound.c libgraph.h \
+ \
\
\
../../byterun/mlvalues.h ../../byterun/compatibility.h \
../../byterun/misc.h ../../byterun/compatibility.h \
../../byterun/config.h
subwindow.o: subwindow.c libgraph.h \
+ \
\
\
../../byterun/mlvalues.h ../../byterun/compatibility.h \
../../byterun/misc.h ../../byterun/compatibility.h \
../../byterun/config.h
text.o: text.c libgraph.h \
+ \
\
\
../../byterun/mlvalues.h ../../byterun/compatibility.h \
# #
#########################################################################
-# $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
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)
../../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
(* *)
(***********************************************************************)
-(* $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. *)
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.
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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.
(* *)
(***********************************************************************)
-(* $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 *)
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
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
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 =
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
;;
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 []
;;
# #
#########################################################################
-# $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:
# stop here -> |
cat >resources/ReadMe.txt <<EOF
This package installs Objective Caml version ${VERSION}.
-You need Mac OS X 10.5.x (Jaguar), with X11 and the
+You need Mac OS X 10.5.x (Leopard), with X11 and the
XCode tools (v3.x) installed.
Files will be installed in the following directories:
EOF
chmod -R g-w root
-sudo chown -R root:admin root
+sudo chown -R root:wheel root
/Developer/Applications/Utilities/PackageMaker.app/Contents/MacOS/PackageMaker \
-build -p "`pwd`/ocaml.pkg" -f "`pwd`/root" -i "`pwd`/Info.plist" \
hdiutil create -sectors $size ocaml-rw.dmg
name=`hdid -nomount ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1`
-newfs_hfs -v 'Objective Caml' $name
+volname="Objective Caml ${VERSION}"
+newfs_hfs -v "$volname" $name
hdiutil detach $name
name=`hdid ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1`
-if test -d '/Volumes/Objective Caml'; then
- ditto -rsrcFork ocaml.pkg "/Volumes/Objective Caml/ocaml.pkg"
- cp resources/ReadMe.txt "/Volumes/Objective Caml/"
+if test -d "/Volumes/$volname"; then
+ ditto -rsrcFork ocaml.pkg "/Volumes/$volname/ocaml.pkg"
+ cp resources/ReadMe.txt "/Volumes/$volname/"
else
- echo 'Unable to mount the disk image as "/Volumes/Objective Caml"' >&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"
(* *)
(***********************************************************************)
-(* $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 *)
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
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
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
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
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) ->
| [] ->
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 []))
(* *)
(***********************************************************************)
-(* $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
"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 ? *)
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
projects / ocaml.git / commitdiff