diff options
37 files changed, 782 insertions, 102 deletions
diff --git a/asmrun/Makefile b/asmrun/Makefile index 8693676c8..43cf4b01f 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -24,7 +24,7 @@ COBJS=startup.o main.o fail.o roots.o signals.o \ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o + compact.o finalise.o custom.o ASMOBJS=$(ARCH).o @@ -128,6 +128,8 @@ compact.c: ../byterun/compact.c ln -s ../byterun/compact.c compact.c finalise.c: ../byterun/finalise.c ln -s ../byterun/finalise.c finalise.c +custom.c: ../byterun/custom.c + ln -s ../byterun/custom.c custom.c meta.c: ../byterun/meta.c ln -s ../byterun/meta.c meta.c diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 925855f10..2d0a0145e 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -22,7 +22,7 @@ COBJS=startup.obj main.obj fail.obj roots.obj signals.obj \ compare.obj ints.obj floats.obj str.obj array.obj io.obj extern.obj \ intern.obj hash.obj sys.obj parsing.obj gc_ctrl.obj terminfo.obj \ md5.obj obj.obj lexing.obj wincmdline.obj printexc.obj callback.obj \ - weak.obj compact.obj finalise.obj + weak.obj compact.obj finalise.obj custom.obj ASMOBJS=$(ARCH)nt.obj @@ -93,6 +93,8 @@ compact.c: ../byterun/compact.c cp ../byterun/compact.c compact.c finalise.c: ../byterun/finalise.c cp ../byterun/finalise.c finalise.c +custom.c: ../byterun/custom.c + cp ../byterun/custom.c custom.c meta.c: ../byterun/meta.c cp ../byterun/meta.c meta.c diff --git a/byterun/.depend b/byterun/.depend index 8f7989ae8..127a48a42 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -1,5 +1,6 @@ alloc.o: alloc.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ - mlvalues.h major_gc.h freelist.h memory.h gc.h minor_gc.h stacks.h + mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h minor_gc.h \ + stacks.h array.o: array.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h callback.o: callback.c callback.h mlvalues.h config.h ../config/m.h \ @@ -8,15 +9,18 @@ callback.o: callback.c callback.h mlvalues.h config.h ../config/m.h \ compact.o: compact.c config.h ../config/m.h ../config/s.h finalise.h \ roots.h misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h \ minor_gc.h gc_ctrl.h weak.h -compare.o: compare.c fail.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h \ +compare.o: compare.c custom.h mlvalues.h config.h ../config/m.h \ + ../config/s.h misc.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +custom.o: custom.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h debugger.o: debugger.c config.h ../config/m.h ../config/s.h debugger.h \ misc.h mlvalues.h fail.h fix_code.h instruct.h intext.h io.h stacks.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h extern.o: extern.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ - mlvalues.h fail.h gc.h intext.h io.h fix_code.h memory.h major_gc.h \ - freelist.h minor_gc.h reverse.h + mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h memory.h \ + major_gc.h freelist.h minor_gc.h reverse.h fail.o: fail.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h io.h gc.h memory.h major_gc.h freelist.h minor_gc.h \ signals.h stacks.h @@ -32,14 +36,14 @@ floats.o: floats.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ freelist.o: freelist.c config.h ../config/m.h ../config/s.h freelist.h \ misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h gc_ctrl.o: gc_ctrl.c alloc.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h compact.h gc.h gc_ctrl.h major_gc.h \ + ../config/s.h mlvalues.h compact.h custom.h gc.h gc_ctrl.h major_gc.h \ freelist.h minor_gc.h stacks.h memory.h hash.o: hash.c mlvalues.h config.h ../config/m.h ../config/s.h misc.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h + custom.h memory.h gc.h major_gc.h freelist.h minor_gc.h instrtrace.o: instrtrace.c intern.o: intern.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ - mlvalues.h fail.h gc.h intext.h io.h fix_code.h memory.h major_gc.h \ - freelist.h minor_gc.h reverse.h + mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h memory.h \ + major_gc.h freelist.h minor_gc.h reverse.h interp.o: interp.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h callback.h debugger.h fail.h fix_code.h instrtrace.h \ instruct.h interp.h major_gc.h freelist.h memory.h gc.h minor_gc.h \ @@ -47,8 +51,8 @@ interp.o: interp.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ ints.o: ints.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h io.o: io.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ - mlvalues.h fail.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - signals.h sys.h + mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h signals.h sys.h lexing.o: lexing.c fail.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h macintosh.o: macintosh.c misc.h config.h ../config/m.h ../config/s.h \ @@ -56,8 +60,8 @@ macintosh.o: macintosh.c misc.h config.h ../config/m.h ../config/s.h \ main.o: main.c misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ sys.h major_gc.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - misc.h fail.h mlvalues.h finalise.h roots.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h gc_ctrl.h weak.h + misc.h custom.h mlvalues.h fail.h finalise.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h md5.o: md5.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h md5.h io.h reverse.h memory.o: memory.c fail.h misc.h config.h ../config/m.h ../config/s.h \ @@ -90,7 +94,7 @@ stacks.o: stacks.c config.h ../config/m.h ../config/s.h fail.h misc.h \ startup.o: startup.c config.h ../config/m.h ../config/s.h alloc.h \ misc.h mlvalues.h callback.h debugger.h exec.h fail.h fix_code.h \ gc_ctrl.h interp.h intext.h io.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h prims.h stacks.h sys.h + minor_gc.h prims.h signals.h stacks.h sys.h str.o: str.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h sys.o: sys.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ @@ -102,7 +106,8 @@ weak.o: weak.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h wincmdline.o: wincmdline.c alloc.d.o: alloc.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ - mlvalues.h major_gc.h freelist.h memory.h gc.h minor_gc.h stacks.h + mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h minor_gc.h \ + stacks.h array.d.o: array.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h callback.d.o: callback.c callback.h mlvalues.h config.h ../config/m.h \ @@ -111,15 +116,18 @@ callback.d.o: callback.c callback.h mlvalues.h config.h ../config/m.h \ compact.d.o: compact.c config.h ../config/m.h ../config/s.h finalise.h \ roots.h misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h \ minor_gc.h gc_ctrl.h weak.h -compare.d.o: compare.c fail.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h \ +compare.d.o: compare.c custom.h mlvalues.h config.h ../config/m.h \ + ../config/s.h misc.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +custom.d.o: custom.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h custom.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h debugger.d.o: debugger.c config.h ../config/m.h ../config/s.h debugger.h \ misc.h mlvalues.h fail.h fix_code.h instruct.h intext.h io.h stacks.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h extern.d.o: extern.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ - mlvalues.h fail.h gc.h intext.h io.h fix_code.h memory.h major_gc.h \ - freelist.h minor_gc.h reverse.h + mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h memory.h \ + major_gc.h freelist.h minor_gc.h reverse.h fail.d.o: fail.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h io.h gc.h memory.h major_gc.h freelist.h minor_gc.h \ signals.h stacks.h @@ -135,15 +143,15 @@ floats.d.o: floats.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ freelist.d.o: freelist.c config.h ../config/m.h ../config/s.h freelist.h \ misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h gc_ctrl.d.o: gc_ctrl.c alloc.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h compact.h gc.h gc_ctrl.h major_gc.h \ + ../config/s.h mlvalues.h compact.h custom.h gc.h gc_ctrl.h major_gc.h \ freelist.h minor_gc.h stacks.h memory.h hash.d.o: hash.c mlvalues.h config.h ../config/m.h ../config/s.h misc.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h + custom.h memory.h gc.h major_gc.h freelist.h minor_gc.h instrtrace.d.o: instrtrace.c instruct.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h opnames.h intern.d.o: intern.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ - mlvalues.h fail.h gc.h intext.h io.h fix_code.h memory.h major_gc.h \ - freelist.h minor_gc.h reverse.h + mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h memory.h \ + major_gc.h freelist.h minor_gc.h reverse.h interp.d.o: interp.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h callback.h debugger.h fail.h fix_code.h instrtrace.h \ instruct.h interp.h major_gc.h freelist.h memory.h gc.h minor_gc.h \ @@ -151,8 +159,8 @@ interp.d.o: interp.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ ints.d.o: ints.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h io.d.o: io.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ - mlvalues.h fail.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - signals.h sys.h + mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h signals.h sys.h lexing.d.o: lexing.c fail.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h macintosh.d.o: macintosh.c misc.h config.h ../config/m.h ../config/s.h \ @@ -160,8 +168,8 @@ macintosh.d.o: macintosh.c misc.h config.h ../config/m.h ../config/s.h \ main.d.o: main.c misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ sys.h major_gc.d.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - misc.h fail.h mlvalues.h finalise.h roots.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h gc_ctrl.h weak.h + misc.h custom.h mlvalues.h fail.h finalise.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h md5.d.o: md5.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h md5.h io.h reverse.h memory.d.o: memory.c fail.h misc.h config.h ../config/m.h ../config/s.h \ @@ -194,7 +202,7 @@ stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h fail.h misc.h \ startup.d.o: startup.c config.h ../config/m.h ../config/s.h alloc.h \ misc.h mlvalues.h callback.h debugger.h exec.h fail.h fix_code.h \ gc_ctrl.h interp.h intext.h io.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h prims.h stacks.h sys.h + minor_gc.h prims.h signals.h stacks.h sys.h str.d.o: str.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h sys.d.o: sys.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ diff --git a/byterun/Makefile b/byterun/Makefile index 7f6d46ade..be22350f6 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -23,7 +23,7 @@ OBJS=interp.o misc.o stacks.o fix_code.o startup.o main.o \ fail.o signals.o printexc.o \ compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \ hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \ - lexing.o callback.o debugger.o weak.o compact.o finalise.o + lexing.o callback.o debugger.o weak.o compact.o finalise.o custom.o DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o @@ -31,7 +31,7 @@ PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \ signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c -PUBLIC_INCLUDES=mlvalues.h alloc.h misc.h callback.h fail.h +PUBLIC_INCLUDES=mlvalues.h alloc.h misc.h callback.h fail.h custom.h all: ocamlrun diff --git a/byterun/Makefile.Mac b/byterun/Makefile.Mac index 78a18dddc..0a1a9c52e 100644 --- a/byterun/Makefile.Mac +++ b/byterun/Makefile.Mac @@ -37,7 +37,7 @@ OBJS = interp.a.o misc.c.o stacks.c.o fix_code.c.o startup.c.o main.c.o ¶ intern.c.o ¶ hash.c.o sys.c.o meta.c.o parsing.c.o gc_ctrl.c.o terminfo.c.o md5.c.o ¶ obj.c.o lexing.c.o macintosh.c.o rotatecursor.c.o printexc.c.o callback.c.o ¶ - debugger.c.o weak.c.o compact.c.o instrtrace.c.o finalise.c.o + debugger.c.o weak.c.o compact.c.o instrtrace.c.o finalise.c.o custom.c.o PPCOBJS = interp.c.x misc.c.x stacks.c.x fix_code.c.x startup.c.x main.c.x ¶ freelist.c.x major_gc.c.x minor_gc.c.x memory.c.x alloc.c.x roots.c.x ¶ @@ -46,13 +46,13 @@ PPCOBJS = interp.c.x misc.c.x stacks.c.x fix_code.c.x startup.c.x main.c.x ¶ intern.c.x ¶ hash.c.x sys.c.x meta.c.x parsing.c.x gc_ctrl.c.x terminfo.c.x md5.c.x ¶ obj.c.x lexing.c.x macintosh.c.x rotatecursor.c.x printexc.c.x callback.c.x ¶ - debugger.c.x weak.c.x compact.c.x instrtrace.c.x finalise.c.x + debugger.c.x weak.c.x compact.c.x instrtrace.c.x finalise.c.x custom.c.x PRIMS = alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c ¶ intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c ¶ signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c -PUBLIC_INCLUDES = mlvalues.h alloc.h misc.h callback.h fail.h +PUBLIC_INCLUDES = mlvalues.h alloc.h misc.h callback.h fail.h custom.h all Ä ocamlrun libcamlrun.o libcamlrun.x diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index 840924553..977083bc3 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -23,13 +23,13 @@ OBJS=interp.obj misc.obj stacks.obj fix_code.obj startup.obj main.obj \ str.obj array.obj io.obj extern.obj intern.obj hash.obj sys.obj \ meta.obj parsing.obj gc_ctrl.obj terminfo.obj md5.obj obj.obj lexing.obj \ wincmdline.obj printexc.obj callback.obj debugger.obj weak.obj compact.obj \ - finalise.obj + finalise.obj custom.obj PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \ signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c -PUBLIC_INCLUDES=mlvalues.h alloc.h misc.h callback.h fail.h +PUBLIC_INCLUDES=mlvalues.h alloc.h misc.h callback.h fail.h custom.h all: ocamlrun.exe diff --git a/byterun/alloc.c b/byterun/alloc.c index d476889c6..7a979f519 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -19,6 +19,7 @@ #include <string.h> #include "alloc.h" +#include "custom.h" #include "major_gc.h" #include "memory.h" #include "mlvalues.h" @@ -78,16 +79,33 @@ value alloc_string (mlsize_t len) return result; } -value alloc_final (mlsize_t len, final_fun fun, mlsize_t mem, mlsize_t max) +value alloc_custom(struct custom_operations * ops, + unsigned long size, + mlsize_t mem, + mlsize_t max) { - value result = alloc_shr (len, Final_tag); + mlsize_t wosize; + value result; - Field (result, 0) = (value) fun; - adjust_gc_speed (mem, max); - result = check_urgent_gc (result); + wosize = 1 + (size + sizeof(value) - 1) / sizeof(value); + if (ops->finalize == NULL && wosize <= Max_young_wosize) { + result = alloc_small(wosize, Custom_tag); + Custom_ops_val(result) = ops; + } else { + result = alloc_shr(wosize, Custom_tag); + Custom_ops_val(result) = ops; + adjust_gc_speed(mem, max); + result = check_urgent_gc(result); + } return result; } +value alloc_final (mlsize_t len, final_fun fun, mlsize_t mem, mlsize_t max) +{ + return alloc_custom(final_custom_operations(fun), + len * sizeof(value), mem, max); +} + value copy_string(char *s) { int len; diff --git a/byterun/alloc.h b/byterun/alloc.h index 4f6d191f2..39a8797d5 100644 --- a/byterun/alloc.h +++ b/byterun/alloc.h @@ -23,12 +23,22 @@ value alloc (mlsize_t, tag_t); value alloc_small (mlsize_t, tag_t); value alloc_tuple (mlsize_t); value alloc_string (mlsize_t); -value alloc_final (mlsize_t, final_fun, mlsize_t, mlsize_t); value copy_string (char *); value copy_string_array (char **); value copy_double (double); value alloc_array (value (*funct) (char *), char ** array); -int convert_flag_list (value, int *); +value alloc_custom(struct custom_operations * ops, + unsigned long size, /*size in bytes*/ + mlsize_t mem, /*resources consumed*/ + mlsize_t max /*max resources*/); + +typedef void (*final_fun)(value); +value alloc_final (mlsize_t /*size in words*/, + final_fun, /*finalization function*/ + mlsize_t, /*resources consumed*/ + mlsize_t /*max resources*/); + +int convert_flag_list (value, int *); #endif /* _alloc_ */ diff --git a/byterun/compare.c b/byterun/compare.c index 7a5cb7b6c..a75e37e1f 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -12,6 +12,7 @@ /* $Id$ */ +#include "custom.h" #include "fail.h" #include "memory.h" #include "misc.h" @@ -74,13 +75,14 @@ static long compare_val(value v1, value v2) return 0; } case Abstract_tag: - case Final_tag: invalid_argument("equal: abstract value"); case Closure_tag: case Infix_tag: invalid_argument("equal: functional value"); case Object_tag: return (Oid_val(v1) - Oid_val(v2)); + case Custom_tag: + return Custom_ops_val(v1)->compare(v1, v2); default: { mlsize_t sz1 = Wosize_val(v1); mlsize_t sz2 = Wosize_val(v2); diff --git a/byterun/custom.c b/byterun/custom.c new file mode 100644 index 000000000..1c013ceab --- /dev/null +++ b/byterun/custom.c @@ -0,0 +1,79 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include "alloc.h" +#include "custom.h" +#include "fail.h" +#include "memory.h" +#include "mlvalues.h" + +int custom_compare_default(value v1, value v2) +{ + failwith("equal: abstract value"); + return 0; +} + +void custom_serialize_default(value v, unsigned long * wsize_32, + unsigned long * wsize_64) +{ + failwith("output_value: abstract value"); +} + +struct custom_operations_list { + struct custom_operations * ops; + struct custom_operations_list * next; +}; + +static struct custom_operations_list * custom_ops_table = NULL; + +void register_custom_operations(struct custom_operations * ops) +{ + struct custom_operations_list * l = + stat_alloc(sizeof(struct custom_operations_list)); + Assert(ops->identifier != NULL); + Assert(ops->deserialize != NULL); + l->ops = ops; + l->next = custom_ops_table; + custom_ops_table = l; +} + +struct custom_operations * find_custom_operations(char * ident) +{ + struct custom_operations_list * l; + for (l = custom_ops_table; l != NULL; l = l->next) + if (strcmp(l->ops->identifier, ident) == 0) return l->ops; + return NULL; +} + +static struct custom_operations_list * custom_ops_final_table = NULL; + +struct custom_operations * final_custom_operations(final_fun fn) +{ + struct custom_operations_list * l; + struct custom_operations * ops; + for (l = custom_ops_final_table; l != NULL; l = l->next) + if (l->ops->finalize == fn) return l->ops; + ops = stat_alloc(sizeof(struct custom_operations)); + ops->identifier = "_final"; + ops->finalize = fn; + ops->compare = custom_compare_default; + ops->hash = custom_hash_default; + ops->serialize = custom_serialize_default; + ops->deserialize = custom_deserialize_default; + l = stat_alloc(sizeof(struct custom_operations_list)); + l->ops = ops; + l->next = custom_ops_final_table; + custom_ops_table = l; + return ops; +} diff --git a/byterun/custom.h b/byterun/custom.h new file mode 100644 index 000000000..6f1d7f324 --- /dev/null +++ b/byterun/custom.h @@ -0,0 +1,44 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#ifndef _custom_ +#define _custom_ + + +#include "mlvalues.h" + +struct custom_operations { + char *identifier; + void (*finalize)(value v); + int (*compare)(value v1, value v2); + long (*hash)(value v); + void (*serialize)(value v, + /*out*/ unsigned long * wsize_32 /*size in bytes*/, + /*out*/ unsigned long * wsize_64 /*size in bytes*/); + unsigned long (*deserialize)(void * dst); +}; + +#define custom_finalize_default NULL +extern int custom_compare_default(value v1, value v2); +#define custom_hash_default NULL +extern void custom_serialize_default(value v, unsigned long * wsize_32, + unsigned long * wsize_64); +#define custom_deserialize_default NULL + +#define Custom_ops_val(v) (*((struct custom_operations **) (v))) + +extern void register_custom_operations(struct custom_operations * ops); +extern struct custom_operations * find_custom_operations(char * ident); + +#endif diff --git a/byterun/extern.c b/byterun/extern.c index 8ad3a76ef..79c10491d 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -16,6 +16,7 @@ #include <string.h> #include "alloc.h" +#include "custom.h" #include "fail.h" #include "gc.h" #include "intext.h" @@ -302,7 +303,6 @@ static void extern_rec(value v) break; } case Abstract_tag: - case Final_tag: extern_invalid_argument("output_value: abstract value"); break; case Infix_tag: @@ -312,6 +312,16 @@ static void extern_rec(value v) case Object_tag: extern_invalid_argument("output_value: object value"); break; + case Custom_tag: { + unsigned long sz_32, sz_64; + char * ident = Custom_ops_val(v)->identifier; + Write(CODE_CUSTOM); + writeblock(ident, strlen(ident) + 1); + Custom_ops_val(v)->serialize(v, &sz_32, &sz_64); + size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */ + size_64 += 2 + ((sz_64 + 7) >> 3); + break; + } default: { mlsize_t i; if (tag < 16 && sz < 8) { @@ -447,3 +457,93 @@ void output_value_to_malloc(value v, value flags, *len = extern_value(v, flags); } +/* Functions for writing user-defined marshallers */ + +void serialize_int_1(int i) +{ + if (extern_ptr + 1 > extern_limit) resize_extern_block(1); + extern_ptr[0] = i; + extern_ptr += 1; +} + +void serialize_int_2(int i) +{ + if (extern_ptr + 2 > extern_limit) resize_extern_block(2); + extern_ptr[0] = i >> 8; + extern_ptr[1] = i; + extern_ptr += 2; +} + +void serialize_int_4(int32 i) +{ + if (extern_ptr + 4 > extern_limit) resize_extern_block(4); + extern_ptr[0] = i >> 24; + extern_ptr[1] = i >> 16; + extern_ptr[2] = i >> 8; + extern_ptr[3] = i; + extern_ptr += 4; +} + +void serialize_int_8(int64 i) +{ + serialize_block_8(&i, 1); +} + +void serialize_float_4(float f) +{ + serialize_block_4(&f, 1); +} + +void serialize_float_8(double f) +{ + serialize_block_8(&f, 1); +} + +void serialize_block_1(void * data, long len) +{ + if (extern_ptr + len > extern_limit) resize_extern_block(len); + bcopy(data, extern_ptr, len); + extern_ptr += len; +} + +void serialize_block_2(void * data, long len) +{ + unsigned char * p, * q; + if (extern_ptr + 2 * len > extern_limit) resize_extern_block(2 * len); +#ifndef ARCH_BIG_ENDIAN + for (p = data, q = extern_ptr; len > 0; len--, p += 2, q += 2) + Reverse_16(q, p); + extern_ptr = q; +#else + bcopy(data, extern_ptr, len * 2); + extern_ptr += len * 2; +#endif +} + +void serialize_block_4(void * data, long len) +{ + unsigned char * p, * q; + if (extern_ptr + 4 * len > extern_limit) resize_extern_block(4 * len); +#ifndef ARCH_BIG_ENDIAN + for (p = data, q = extern_ptr; len > 0; len--, p += 4, q += 4) + Reverse_32(q, p); + extern_ptr = q; +#else + bcopy(data, extern_ptr, len * 4); + extern_ptr += len * 4; +#endif +} + +void serialize_block_8(void * data, long len) +{ + unsigned char * p, * q; + if (extern_ptr + 8 * len > extern_limit) resize_extern_block(8 * len); +#ifndef ARCH_BIG_ENDIAN + for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8) + Reverse_64(q, p); + extern_ptr = q; +#else + bcopy(data, extern_ptr, len * 8); + extern_ptr += len * 8; +#endif +} diff --git a/byterun/finalise.c b/byterun/finalise.c index 9f96a3069..e0c548226 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -20,7 +20,7 @@ #include "roots.h" #include "signals.h" -typedef struct final { +struct final { value fun; value val; }; diff --git a/byterun/fix_code.c b/byterun/fix_code.c index e6ac127dc..6496ee4db 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -71,7 +71,7 @@ void fixup_endianness(code_t code, asize_t len) code_t p; len /= sizeof(opcode_t); for (p = code; p < code + len; p++) { - Reverse_int32(p); + Reverse_32(p, p); } } diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index a0adb0cdc..89bf63856 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -14,6 +14,7 @@ #include "alloc.h" #include "compact.h" +#include "custom.h" #include "gc.h" #include "gc_ctrl.h" #include "major_gc.h" @@ -91,8 +92,8 @@ static void check_block (char *hp) case Double_array_tag: Assert (Wosize_val (v) % Double_wosize == 0); break; - case Final_tag: - Assert (!Is_in_heap (Final_fun (v))); + case Custom_tag: + Assert (!Is_in_heap (Custom_ops_val (v))); break; case Infix_tag: diff --git a/byterun/hash.c b/byterun/hash.c index b71ae6c0e..af756eaf2 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -15,6 +15,7 @@ /* The generic hashing primitive */ #include "mlvalues.h" +#include "custom.h" #include "memory.h" static unsigned long hash_accu; @@ -96,7 +97,6 @@ static void hash_aux(value obj) } break; case Abstract_tag: - case Final_tag: /* We don't know anything about the contents of the block. Better do nothing. */ break; @@ -107,6 +107,13 @@ static void hash_aux(value obj) hash_univ_count--; Combine(Oid_val(obj)); break; + case Custom_tag: + /* If no hashing function provided, do nothing */ + if (Custom_ops_val(obj)->hash != NULL) { + hash_univ_count--; + Combine(Custom_ops_val(obj)->hash(obj)); + } + break; default: hash_univ_count--; Combine_small(tag); diff --git a/byterun/intern.c b/byterun/intern.c index 786674920..b45e8d50d 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -16,6 +16,7 @@ #include <string.h> #include "alloc.h" +#include "custom.h" #include "fail.h" #include "gc.h" #include "intext.h" @@ -116,6 +117,7 @@ static void intern_rec(value *dest) asize_t ofs; header_t header; char cksum[16]; + struct custom_operations * ops; tailcall: code = read8u(); @@ -210,7 +212,7 @@ static void intern_rec(value *dest) *intern_dest = Make_header(Double_wosize, Double_tag, intern_color); intern_dest += 1 + Double_wosize; readblock((char *) v, 8); - if (code != CODE_DOUBLE_NATIVE) Reverse_double(v); + if (code != CODE_DOUBLE_NATIVE) Reverse_64(v, v); break; case CODE_DOUBLE_ARRAY8_LITTLE: case CODE_DOUBLE_ARRAY8_BIG: @@ -229,7 +231,8 @@ static void intern_rec(value *dest) if (code != CODE_DOUBLE_ARRAY8_NATIVE && code != CODE_DOUBLE_ARRAY32_NATIVE) { mlsize_t i; - for (i = 0; i < len; i++) Reverse_double((value)((double *)v + i)); + for (i = 0; i < len; i++) Reverse_64((value)((double *)v + i), + (value)((double *)v + i)); } break; case CODE_DOUBLE_ARRAY32_LITTLE: @@ -250,6 +253,20 @@ static void intern_rec(value *dest) intern_rec(&clos); v = clos + ofs; break; + case CODE_CUSTOM: + ops = find_custom_operations((char *) intern_src); + if (ops == NULL) { + intern_cleanup(); + failwith("input_value: unknown custom block identifier"); + } + while (*intern_src++ != 0) /*nothing*/; /*skip identifier*/ + size = ops->deserialize((void *) (intern_dest + 2)); + size = 1 + (size + sizeof(value) - 1) / sizeof(value); + v = Val_hp(intern_dest); + *intern_dest = Make_header(size, Custom_tag, intern_color); + Custom_ops_val(v) = ops; + intern_dest += 1 + size; + break; default: intern_cleanup(); failwith("input_value: ill-formed message"); @@ -468,3 +485,108 @@ unsigned char * code_checksum(void) } #endif + +/* Functions for writing user-defined marshallers */ + +int deserialize_uint_1(void) +{ + return read8u(); +} + +int deserialize_sint_1(void) +{ + return read8s(); +} + +int deserialize_uint_2(void) +{ + return read16u(); +} + +int deserialize_sint_2(void) +{ + return read16s(); +} + +uint32 deserialize_uint_4(void) +{ + return read32u(); +} + +int32 deserialize_sint_4(void) +{ + return read32s(); +} + +uint64 deserialize_uint_8(void) +{ + uint64 i; + deserialize_block_8(&i, 1); + return i; +} + +int64 deserialize_sint_8(void) +{ + int64 i; + deserialize_block_8(&i, 1); + return i; +} + +float deserialize_float_4(void) +{ + float f; + deserialize_block_4(&f, 1); + return f; +} + +double deserialize_float_8(void) +{ + double f; + deserialize_block_8(&f, 1); + return f; +} + +void deserialize_block_1(void * data, long len) +{ + bcopy(intern_src, data, len); + intern_src += len; +} + +void deserialize_block_2(void * data, long len) +{ + unsigned char * p, * q; +#ifndef ARCH_BIG_ENDIAN + for (p = intern_src, q = data; len > 0; len--, p += 2, q += 2) + Reverse_16(q, p); + intern_src = p; +#else + bcopy(intern_src, data, len * 2); + intern_src += len * 2; +#endif +} + +void deserialize_block_4(void * data, long len) +{ + unsigned char * p, * q; +#ifndef ARCH_BIG_ENDIAN + for (p = intern_src, q = data; len > 0; len--, p += 4, q += 4) + Reverse_32(q, p); + intern_src = p; +#else + bcopy(intern_src, data, len * 4); + intern_src += len * 4; +#endif +} + +void deserialize_block_8(void * data, long len) +{ + unsigned char * p, * q; +#ifndef ARCH_BIG_ENDIAN + for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) + Reverse_64(q, p); + intern_src = p; +#else + bcopy(intern_src, data, len * 8); + intern_src += len * 8; +#endif +} diff --git a/byterun/intext.h b/byterun/intext.h index d56432406..c346dcb44 100644 --- a/byterun/intext.h +++ b/byterun/intext.h @@ -48,6 +48,7 @@ #define CODE_DOUBLE_ARRAY32_LITTLE 0x7 #define CODE_CODEPOINTER 0x10 #define CODE_INFIXPOINTER 0x11 +#define CODE_CUSTOM 0x12 #ifdef ARCH_BIG_ENDIAN #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG @@ -84,6 +85,34 @@ void output_val (struct channel * chan, value v, value flags); value input_val (struct channel * chan); value input_val_from_string (value str, long ofs); +/* Functions for writing user-defined marshallers */ + +extern void serialize_int_1(int i); +extern void serialize_int_2(int i); +extern void serialize_int_4(int32 i); +extern void serialize_int_8(int64 i); +extern void serialize_float_4(float f); +extern void serialize_float_8(double f); +extern void serialize_block_1(void * data, long len); +extern void serialize_block_2(void * data, long len); +extern void serialize_block_4(void * data, long len); +extern void serialize_block_8(void * data, long len); + +extern int deserialize_uint_1(void); +extern int deserialize_sint_1(void); +extern int deserialize_uint_2(void); +extern int deserialize_sint_2(void); +extern uint32 deserialize_uint_4(void); +extern int32 deserialize_sint_4(void); +extern uint64 deserialize_uint_8(void); +extern int64 deserialize_sint_8(void); +extern float deserialize_float_4(void); +extern double deserialize_float_8(void); +extern void deserialize_block_1(void * data, long len); +extern void deserialize_block_2(void * data, long len); +extern void deserialize_block_4(void * data, long len); +extern void deserialize_block_8(void * data, long len); + /* Auxiliary stuff for sending code pointers */ unsigned char * code_checksum (void); @@ -95,6 +124,5 @@ unsigned char * code_checksum (void); extern char * code_area_start, * code_area_end; #endif - #endif diff --git a/byterun/io.c b/byterun/io.c index c90cc71f3..5267ca4ce 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -23,6 +23,7 @@ #include <unistd.h> #endif #include "alloc.h" +#include "custom.h" #include "fail.h" #include "io.h" #include "memory.h" @@ -375,10 +376,20 @@ static void finalize_channel(value vchan) stat_free(chan); } +static struct custom_operations channel_operations = { + "_chan", + finalize_channel, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + static value alloc_channel(struct channel *chan) { - value res = alloc_final(2, finalize_channel, 1, 1000); - Field(res, 1) = (value) chan; + value res = alloc_custom(&channel_operations, sizeof(struct channel *), + 1, 1000); + Channel(res) = chan; return res; } diff --git a/byterun/io.h b/byterun/io.h index 1df9891f0..ee6ae4016 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -70,7 +70,7 @@ int really_getblock (struct channel *, char *, long); /* Extract a struct channel * from the heap object representing it */ -#define Channel(v) ((struct channel *) Field(v, 1)) +#define Channel(v) (*((struct channel **) (Data_custom_val(v)))) /* The locking machinery */ diff --git a/byterun/major_gc.c b/byterun/major_gc.c index a34ebd4fa..8435d1645 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -15,6 +15,7 @@ #include <limits.h> #include "compact.h" +#include "custom.h" #include "config.h" #include "fail.h" #include "finalise.h" @@ -226,8 +227,9 @@ static void sweep_slice (long int work) gc_sweep_hp += Bhsize_hd (hd); switch (Color_hd (hd)){ case Caml_white: - if (Tag_hd (hd) == Final_tag){ - Final_fun (Val_hp (hp)) (Val_hp (hp)); + if (Tag_hd (hd) == Custom_tag){ + void (*final_fun)(value) = Custom_ops_val(Val_hp(hp)); + if (final_fun != NULL) final_fun(Val_hp(hp)); } gc_sweep_hp = fl_merge_block (Bp_hp (hp)); break; diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index 8753c97a9..6c66492cc 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -34,6 +34,7 @@ op: Pointer to the first field of a block. (a value *) hp: Pointer to the header of a block. (a char *) int32: Four bytes on all architectures. + int64: Eight bytes on all architectures. Remark: A block size is always a multiple of the word size, and at least one word plus the header. @@ -67,6 +68,9 @@ typedef short int32; typedef unsigned short uint32; #endif +typedef long int64; /* FIXME */ +typedef unsigned long uint64; /* FIXME */ + /* Longs vs blocks. */ #define Is_long(x) (((x) & 1) != 0) #define Is_block(x) (((x) & 1) == 0) @@ -222,12 +226,14 @@ void Store_double_val (value,double); #define Store_double_field(v,i,d) \ Store_double_val((value)((double *)(v) + (i)),d) -/* Finalized things. Just like abstract things, but the GC will call the - [Final_fun] before deallocation. -*/ -#define Final_tag 255 -typedef void (*final_fun) (value); -#define Final_fun(val) (((final_fun *) (val)) [0]) /* Also an l-value. */ +/* Custom blocks. They contain a pointer to a "method suite" + of functions (for finalization, comparison, hashing, etc) + followed by raw data. The contents of custom blocks is not traced by + the GC; therefore, they must not contain any [value]. + See [custom.h] for operations on method suites. */ +#define Custom_tag 255 +#define Data_custom_val(v) ((void *) &Field(v, 1)) +struct custom_operations; /* defined in [custom.h] */ /* 3- Atoms are 0-tuples. They are statically allocated once and for all. */ diff --git a/otherlibs/graph/image.c b/otherlibs/graph/image.c index c8792a7bd..01f2c7ee9 100644 --- a/otherlibs/graph/image.c +++ b/otherlibs/graph/image.c @@ -15,6 +15,7 @@ #include "libgraph.h" #include "image.h" #include <alloc.h> +#include <custom.h> static void gr_free_image(value im) { @@ -22,11 +23,21 @@ static void gr_free_image(value im) if (Mask_im(im) != None) XFreePixmap(grdisplay, Mask_im(im)); } -#define Max_image_mem 1000000 +static struct custom_operations image_ops = { + "_image", + gr_free_image, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +#define Max_image_mem 2000000 value gr_new_image(int w, int h) { - value res = alloc_final(Grimage_wosize, gr_free_image, w*h, Max_image_mem); + value res = alloc_custom(&image_ops, sizeof(struct grimage), + w * h, Max_image_mem); Width_im(res) = w; Height_im(res) = h; Data_im(res) = XCreatePixmap(grdisplay, grwindow.win, w, h, diff --git a/otherlibs/graph/image.h b/otherlibs/graph/image.h index 0c6175c30..a7dff9193 100644 --- a/otherlibs/graph/image.h +++ b/otherlibs/graph/image.h @@ -13,19 +13,15 @@ /* $Id$ */ struct grimage { - final_fun f; /* Finalization function */ int width, height; /* Dimensions of the image */ Pixmap data; /* Pixels */ Pixmap mask; /* Mask for transparent points, or None */ }; -#define Grimage_wosize \ - ((sizeof(struct grimage) + sizeof(value) - 1) / sizeof(value)) - -#define Width_im(i) (((struct grimage *)(i))->width) -#define Height_im(i) (((struct grimage *)(i))->height) -#define Data_im(i) (((struct grimage *)(i))->data) -#define Mask_im(i) (((struct grimage *)(i))->mask) +#define Width_im(i) (((struct grimage *)Data_custom_val(i))->width) +#define Height_im(i) (((struct grimage *)Data_custom_val(i))->height) +#define Data_im(i) (((struct grimage *)Data_custom_val(i))->data) +#define Mask_im(i) (((struct grimage *)Data_custom_val(i))->mask) #define Transparent (-1) diff --git a/otherlibs/num/nat.h b/otherlibs/num/nat.h index a54f4c13c..ccd650a9f 100644 --- a/otherlibs/num/nat.h +++ b/otherlibs/num/nat.h @@ -12,10 +12,7 @@ /* $Id$ */ -/* Nats are represented as unstructured blocks with tag Nat_tag. */ +/* Nats are represented as unstructured blocks with tag Custom_tag. */ -#define Nat_tag Abstract_tag /* works OK with equal because no other - object uses that tag yet. */ - -#define Bignum_val(nat) ((BigNum) nat) +#define Bignum_val(nat) ((BigNum) Data_custom_val(nat)) diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml index cacdbeb7b..98a994b2c 100644 --- a/otherlibs/num/nat.ml +++ b/otherlibs/num/nat.ml @@ -21,7 +21,6 @@ external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat" external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat" external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" external nth_digit_nat: nat -> int -> int = "nth_digit_nat" -external length_nat: nat -> int = "%obj_size" external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" external is_digit_int: nat -> int -> bool = "is_digit_int" @@ -45,6 +44,11 @@ external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat" external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat" external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat" +external initialize_nat: unit -> unit = "initialize_nat" +let _ = initialize_nat() + +let length_nat (n : nat) = Obj.size (Obj.repr n) - 1 + let length_of_digit = Sys.word_size;; let make_nat len = @@ -561,3 +565,4 @@ let sys_nat_of_string base s off len = let nat_of_string s = sys_nat_of_string 10 s 0 (String.length s) let float_of_nat nat = float_of_string(string_of_nat nat) + diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli index e90c18c07..186153d3a 100644 --- a/otherlibs/num/nat.mli +++ b/otherlibs/num/nat.mli @@ -26,7 +26,7 @@ external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat" val copy_nat: nat -> int -> int -> nat external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" external nth_digit_nat: nat -> int -> int = "nth_digit_nat" -external length_nat: nat -> int = "%obj_size" +val length_nat: nat -> int val length_nat : nat -> int external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c index 3cd8b14a3..6fee76932 100644 --- a/otherlibs/num/nat_stubs.c +++ b/otherlibs/num/nat_stubs.c @@ -14,6 +14,8 @@ #define CAML_LIGHT #include "alloc.h" +#include "custom.h" +#include "intext.h" #include "memory.h" #include "mlvalues.h" #include "nat.h" @@ -23,11 +25,34 @@ /* Stub code for the BigNum package. */ +static void serialize_nat(value, unsigned long *, unsigned long *); +static unsigned long deserialize_nat(void * dst); + +static struct custom_operations nat_operations = { + "_nat", + custom_finalize_default, + custom_compare_default, + custom_hash_default, + serialize_nat, + deserialize_nat +}; + +value initialize_nat(value unit) +{ + register_custom_operations(&nat_operations); + return Val_unit; +} + value create_nat(value size) { mlsize_t sz = Long_val(size); - return alloc(sz, Nat_tag); + return alloc_custom(&nat_operations, sz * sizeof(value), 0, 1); +} + +value length_nat(value nat) +{ + return Val_long(Wosize_val(nat) - 1); } value set_to_zero_nat(value nat, value ofs, value len) @@ -251,3 +276,57 @@ value lxor_digit_nat(value nat1, value ofs1, value nat2, value ofs2) return Val_unit; } +/* The wire format for a nat is: + - 32-bit word: number of 32-bit words in nat + - N 32-bit words (big-endian format) + For little-endian platforms, the memory layout between 32-bit and 64-bit + machines is identical, so we can write the nat using serialize_block_4. + For big-endian 64-bit platforms, we need to swap the two 32-bit halves + of 64-bit words to obtain the correct behavior. */ + +static void serialize_nat(value nat, + unsigned long * wsize_32, + unsigned long * wsize_64) +{ + mlsize_t len = Wosize_val(nat) - 1; + +#ifdef ARCH_SIXTYFOUR + len = len * 2; /* two 32-bit words per 64-bit digit */ + if (len >= (1L << 32)) + failwith("output_value: nat too big"); +#endif + serialize_int_4((int32) len); +#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN) + { int32 * p; + mlsize_t i; + for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) { + serialize_int_4(p[1]); /* low 32 bits of 64-bit digit */ + serialize_int_4(p[0]); /* high 32 bits of 64-bit digit */ + } + } +#else + serialize_block_4(Data_custom_val(nat), len); +#endif + *wsize_32 = len * 4; + *wsize_64 = len * 4; +} + +static unsigned long deserialize_nat(void * dst) +{ + mlsize_t len; + + len = deserialize_uint_4(); +#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN) + { uint32 * p; + mlsize_t i; + for (i = len, p = dst; i > 0; i -= 2, p += 2) { + p[1] = deserialize_uint_4(); /* low 32 bits of 64-bit digit */ + p[0] = deserialize_uint_4(); /* high 32 bits of 64-bit digit */ + } + } +#else + deserialize_block_4(dst, len); +#endif + return len * 4; +} + diff --git a/otherlibs/num/test/Makefile b/otherlibs/num/test/Makefile index 3134ed143..b26a9687b 100644 --- a/otherlibs/num/test/Makefile +++ b/otherlibs/num/test/Makefile @@ -20,7 +20,8 @@ test: test.byt test.opt ./test.opt TESTFILES=test.cmo \ - test_nats.cmo test_big_ints.cmo test_ratios.cmo test_nums.cmo end_test.cmo + test_nats.cmo test_big_ints.cmo test_ratios.cmo test_nums.cmo \ + test_io.cmo end_test.cmo TESTOPTFILES=$(TESTFILES:.cmo=.cmx) diff --git a/otherlibs/num/test/Makefile.Mac b/otherlibs/num/test/Makefile.Mac index 72b96fd21..a0db6325b 100644 --- a/otherlibs/num/test/Makefile.Mac +++ b/otherlibs/num/test/Makefile.Mac @@ -19,7 +19,7 @@ test Ä test.byt :test.byt TESTFILES = test.cmo test_nats.cmo test_big_ints.cmo ¶ - test_ratios.cmo test_nums.cmo end_test.cmo + test_ratios.cmo test_nums.cmo test_io.cmo end_test.cmo test.byt Ä {TESTFILES} ::nums.cma ::libnums.o alias ocamlc "{CAMLC}" diff --git a/otherlibs/num/test/Makefile.nt b/otherlibs/num/test/Makefile.nt index 407f1b108..0062f1ce3 100644 --- a/otherlibs/num/test/Makefile.nt +++ b/otherlibs/num/test/Makefile.nt @@ -20,7 +20,8 @@ test: test.byt test.opt .\test.opt TESTFILES=test.cmo \ - test_nats.cmo test_big_ints.cmo test_ratios.cmo test_nums.cmo end_test.cmo + test_nats.cmo test_big_ints.cmo test_ratios.cmo test_nums.cmo \ + test_io.cmo end_test.cmo TESTOPTFILES=$(TESTFILES:.cmo=.cmx) diff --git a/otherlibs/num/test/test_io.ml b/otherlibs/num/test/test_io.ml new file mode 100644 index 000000000..1df11a5fe --- /dev/null +++ b/otherlibs/num/test/test_io.ml @@ -0,0 +1,64 @@ +open Test +open Nat +open Big_int +open Num + +let intern_extern obj = + let f = Filename.temp_file "testnum" ".data" in + let oc = open_out_bin f in + output_value oc obj; + close_out oc; + let ic = open_in_bin f in + let res = input_value ic in + close_in ic; + Sys.remove f; + res +;; + +testing_function "output_value/input_value on nats";; + +let equal_nat n1 n2 = + eq_nat n1 0 (length_nat n1) n2 0 (length_nat n2) +;; + +List.iter + (fun (i, s) -> + let n = nat_of_string s in + ignore(test i equal_nat (n, intern_extern n))) + [1, "0"; + 2, "1234"; + 3, "8589934592"; + 4, "340282366920938463463374607431768211455"; + 5, String.make 100 '3'; + 6, String.make 1000 '9'; + 7, String.make 20000 '8'] +;; + +testing_function "output_value/input_value on big ints";; + +List.iter + (fun (i, s) -> + let b = big_int_of_string s in + ignore(test i eq_big_int (b, intern_extern b))) + [1, "0"; + 2, "1234"; + 3, "-1234"; + 4, "1040259735709286400"; + 5, "-" ^ String.make 20000 '7'] +;; + +testing_function "output_value/input_value on nums";; + +List.iter + (fun (i, s) -> + let n = num_of_string s in + ignore(test i eq_num (n, intern_extern n))) + [1, "0"; + 2, "1234"; + 3, "-1234"; + 4, "159873568791325097646845892426782"; + 5, "1/4"; + 6, "-15/2"; + 7, "159873568791325097646845892426782/24098772507410987265987"; + 8, String.make 10000 '3' ^ "/" ^ String.make 5000 '7'] +;; diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c index caa03e423..1ff544122 100644 --- a/otherlibs/str/strstubs.c +++ b/otherlibs/str/strstubs.c @@ -7,11 +7,12 @@ #include <regex.h> #include <mlvalues.h> #include <alloc.h> +#include <custom.h> #include <fail.h> #include <memory.h> struct regexp_struct { - final_fun finalization; + struct custom_operations * ops; struct re_pattern_buffer re; }; @@ -24,11 +25,19 @@ static void free_regexp(value vexpr) regfree(&(expr->re)); } +static struct custom_operations regexp_ops = { + "_regexp", + free_regexp, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + static regexp alloc_regexp(void) { value res = - alloc_final(sizeof(struct regexp_struct) / sizeof(value), - free_regexp, 1, 10000); + alloc_custom(®exp_ops, sizeof(struct regexp_struct), 1, 10000); return (regexp) res; } diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index 5f3c56d0f..bc58b4bc2 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -24,6 +24,7 @@ #include <sys/time.h> #include "alloc.h" #include "callback.h" +#include "custom.h" #include "fail.h" #include "io.h" #include "memory.h" @@ -444,7 +445,7 @@ value caml_thread_join(value th) /* ML */ /* Mutex operations */ -#define Mutex_val(v) ((pthread_mutex_t *) Field(v, 1)) +#define Mutex_val(v) (* ((pthread_mutex_t **) Data_custom_val(v))) #define Max_mutex_number 1000 static void caml_mutex_finalize(value wrapper) @@ -454,14 +455,31 @@ static void caml_mutex_finalize(value wrapper) stat_free(mut); } +static int caml_mutex_condition_compare(value wrapper1, value wrapper2) +{ + pthread_mutex_t * mut1 = Mutex_val(wrapper1); + pthread_mutex_t * mut2 = Mutex_val(wrapper2); + return mut1 == mut2 ? 0 : mut1 < mut2 ? -1 : 1; +} + +static struct custom_operations caml_mutex_ops = { + "_mutex", + caml_mutex_finalize, + caml_mutex_condition_compare, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + value caml_mutex_new(value unit) /* ML */ { pthread_mutex_t * mut; value wrapper; mut = stat_alloc(sizeof(pthread_mutex_t)); caml_pthread_check(pthread_mutex_init(mut, NULL), "Mutex.create"); - wrapper = alloc_final(2, caml_mutex_finalize, 1, Max_mutex_number); - Field(wrapper, 1) = (value) mut; + wrapper = alloc_custom(&caml_mutex_ops, sizeof(pthread_mutex_t *), + 1, Max_mutex_number); + Mutex_val(wrapper) = mut; return wrapper; } @@ -503,7 +521,7 @@ value caml_mutex_try_lock(value wrapper) /* ML */ /* Conditions operations */ -#define Condition_val(v) ((pthread_cond_t *) Field(v, 1)) +#define Condition_val(v) (* ((pthread_cond_t **) Data_custom_val(v))) #define Max_condition_number 1000 static void caml_condition_finalize(value wrapper) @@ -513,14 +531,24 @@ static void caml_condition_finalize(value wrapper) stat_free(cond); } +static struct custom_operations caml_condition_ops = { + "_condition", + caml_condition_finalize, + caml_mutex_condition_compare, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + value caml_condition_new(value unit) /* ML */ { pthread_cond_t * cond; value wrapper; cond = stat_alloc(sizeof(pthread_cond_t)); caml_pthread_check(pthread_cond_init(cond, NULL), "Condition.create"); - wrapper = alloc_final(2, caml_condition_finalize, 1, Max_condition_number); - Field(wrapper, 1) = (value) cond; + wrapper = alloc_custom(&caml_condition_ops, sizeof(pthread_cond_t *), + 1, Max_condition_number); + Condition_val(wrapper) = cond; return wrapper; } diff --git a/otherlibs/systhreads/win32.c b/otherlibs/systhreads/win32.c index 35a26ae39..463bd3b98 100644 --- a/otherlibs/systhreads/win32.c +++ b/otherlibs/systhreads/win32.c @@ -18,6 +18,7 @@ #include <signal.h> #include "alloc.h" #include "callback.h" +#include "custom.h" #include "fail.h" #include "io.h" #include "memory.h" @@ -432,7 +433,7 @@ value caml_thread_join(value th) /* ML */ /* Mutex operations */ -#define Mutex_val(v) (*((HANDLE *)(&Field(v, 1)))) +#define Mutex_val(v) (*((HANDLE *) Data_custom_val(v))) #define Max_mutex_number 1000 static void caml_mutex_finalize(value mut) @@ -440,11 +441,26 @@ static void caml_mutex_finalize(value mut) CloseHandle(Mutex_val(mut)); } +static int caml_mutex_compare(value wrapper1, value wrapper2) +{ + HANDLE h1 = Mutex_val(wrapper1); + HANDLE h2 = Mutex_val(wrapper2); + return mut1 == mut2 ? 0 : mut1 < mut2 ? -1 : 1; +} + +static struct custom_operations caml_mutex_ops = { + "_mutex", + caml_mutex_finalize, + caml_mutex_condition_compare, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + value caml_mutex_new(value unit) /* ML */ { value mut; - mut = alloc_final(1 + sizeof(HANDLE) / sizeof(value), - caml_mutex_finalize, 1, Max_mutex_number); + mut = alloc_custom(&caml_mutex_ops, sizeof(HANDLE), 1, Max_mutex_number); Mutex_val(mut) = CreateMutex(0, FALSE, NULL); if (Mutex_val(mut) == NULL) caml_wthread_error("Mutex.create"); return mut; @@ -496,12 +512,11 @@ value caml_thread_delay(value val) /* ML */ /* Conditions operations */ struct caml_condvar { - void (*final_fun)(); /* Finalization function */ unsigned long count; /* Number of waiting threads */ HANDLE sem; /* Semaphore on which threads are waiting */ }; -#define Condition_val(v) ((struct caml_condvar *)(v)) +#define Condition_val(v) ((struct caml_condvar *) Data_custom_val(v)) #define Max_condition_number 1000 static void caml_condition_finalize(value cond) @@ -509,11 +524,27 @@ static void caml_condition_finalize(value cond) CloseHandle(Condition_val(cond)->sem); } +static int caml_condition_compare(value wrapper1, value wrapper2) +{ + HANDLE h1 = Condition_val(wrapper1)->sem; + HANDLE h2 = Condition_val(wrapper2)->sem; + return mut1 == mut2 ? 0 : mut1 < mut2 ? -1 : 1; +} + +static struct custom_operations caml_condition_ops = { + "_condition", + caml_condition_finalize, + caml_condition_compare, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + value caml_condition_new(value unit) /* ML */ { value cond; - cond = alloc_final(sizeof(struct caml_condvar) / sizeof(value), - caml_condition_finalize, 1, Max_condition_number); + cond = alloc_custom(&caml_condition_ops, sizeof(struct caml_condvar), + 1, Max_condition_number); Condition_val(cond)->sem = CreateSemaphore(NULL, 0, 0x7FFFFFFF, NULL); if (Condition_val(cond)->sem == NULL) caml_wthread_error("Condition.create"); diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml index 3fc51ac37..823d0c5a2 100644 --- a/otherlibs/threads/threadUnix.ml +++ b/otherlibs/threads/threadUnix.ml @@ -89,6 +89,11 @@ let pipe() = Unix.set_nonblock out_fd; fd_pair +let open_process_in cmd = + let ic = Unix.open_process_in cmd in + Unix.set_nonblock(Unix.descr_of_in_channel ic); + oc + let open_process_out cmd = let oc = Unix.open_process_out cmd in Unix.set_nonblock(Unix.descr_of_out_channel oc); @@ -96,7 +101,15 @@ let open_process_out cmd = let open_process cmd = let (ic, oc as channels) = Unix.open_process cmd in + Unix.set_nonblock(Unix.descr_of_in_channel ic); + Unix.set_nonblock(Unix.descr_of_out_channel oc); + channels + +let open_process_full cmd env = + let (ic, oc, ec as channels) = Unix.open_process_full cmd env in + Unix.set_nonblock(Unix.descr_of_in_channel ic); Unix.set_nonblock(Unix.descr_of_out_channel oc); + Unix.set_nonblock(Unix.descr_of_out_channel ec); channels (*** Time *) diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli index 2383c35c4..f8e37c7f9 100644 --- a/otherlibs/threads/threadUnix.mli +++ b/otherlibs/threads/threadUnix.mli @@ -57,8 +57,11 @@ val select : (*** Pipes and redirections *) val pipe : unit -> Unix.file_descr * Unix.file_descr +val open_process_in: string -> in_channel val open_process_out: string -> out_channel val open_process: string -> in_channel * out_channel +val open_process_full: + string -> env:string array -> in_channel * out_channel * in_channel (*** Time *) |