diff options
Diffstat (limited to 'byterun')
57 files changed, 6500 insertions, 0 deletions
diff --git a/byterun/.depend b/byterun/.depend new file mode 100644 index 0000000000..d43a9d1d88 --- /dev/null +++ b/byterun/.depend @@ -0,0 +1,121 @@ +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 +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 +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 minor_gc.h str.h +crc.o : crc.c io.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h +extern.o : extern.c fail.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + gc.h intext.h io.h memory.h major_gc.h freelist.h minor_gc.h reverse.h str.h +fail.o : fail.c alloc.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + fail.h gc.h memory.h major_gc.h freelist.h minor_gc.h signals.h stacks.h +fix_code.o : fix_code.c config.h ../config/m.h ../config/s.h fix_code.h misc.h \ + mlvalues.h instruct.h reverse.h +floats.o : floats.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 stacks.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 \ + gc.h gc_ctrl.h major_gc.h freelist.h minor_gc.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 str.h +instrtrace.o : instrtrace.c +intern.o : intern.c fail.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + gc.h intext.h io.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 \ + fail.h fix_code.h instruct.h interp.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + prims.h signals.h stacks.h str.h instrtrace.h jumptbl.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 alloc.h misc.h config.h ../config/m.h ../config/s.h mlvalues.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 interp.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 str.h +main.o : main.c alloc.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + exec.h fail.h gc_ctrl.h interp.h intext.h io.h stacks.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h sys.h +major_gc.o : major_gc.c config.h ../config/m.h ../config/s.h fail.h misc.h mlvalues.h \ + freelist.h gc.h gc_ctrl.h major_gc.h roots.h +memory.o : memory.c fail.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + freelist.h gc.h gc_ctrl.h major_gc.h memory.h minor_gc.h +meta.o : meta.c alloc.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + interp.h major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h +minor_gc.o : minor_gc.c config.h ../config/m.h ../config/s.h fail.h misc.h mlvalues.h \ + gc.h gc_ctrl.h major_gc.h freelist.h memory.h minor_gc.h roots.h +misc.o : misc.c config.h ../config/m.h ../config/s.h misc.h +parsing.o : parsing.c config.h ../config/m.h ../config/s.h mlvalues.h misc.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h alloc.h +prims.o : prims.c mlvalues.h config.h ../config/m.h ../config/s.h misc.h prims.h +roots.o : roots.c memory.h config.h ../config/m.h ../config/s.h gc.h mlvalues.h \ + misc.h major_gc.h freelist.h minor_gc.h roots.h stacks.h +signals.o : signals.c alloc.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + fail.h interp.h memory.h gc.h major_gc.h freelist.h minor_gc.h roots.h signals.h +stacks.o : stacks.c config.h ../config/m.h ../config/s.h fail.h misc.h mlvalues.h \ + stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.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 mlvalues.h \ + fail.h instruct.h signals.h stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h +terminfo.o : terminfo.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ + mlvalues.h fail.h io.h +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 +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 +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 minor_gc.h str.h +crc.d.o : crc.c io.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h +extern.d.o : extern.c fail.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + gc.h intext.h io.h memory.h major_gc.h freelist.h minor_gc.h reverse.h str.h +fail.d.o : fail.c alloc.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + fail.h gc.h memory.h major_gc.h freelist.h minor_gc.h signals.h stacks.h +fix_code.d.o : fix_code.c config.h ../config/m.h ../config/s.h fix_code.h misc.h \ + mlvalues.h instruct.h reverse.h +floats.d.o : floats.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 stacks.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 \ + gc.h gc_ctrl.h major_gc.h freelist.h minor_gc.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 str.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 fail.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + gc.h intext.h io.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 \ + fail.h fix_code.h instruct.h interp.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + prims.h signals.h stacks.h str.h instrtrace.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 alloc.h misc.h config.h ../config/m.h ../config/s.h mlvalues.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 interp.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 str.h +main.d.o : main.c alloc.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + exec.h fail.h gc_ctrl.h interp.h intext.h io.h stacks.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h sys.h +major_gc.d.o : major_gc.c config.h ../config/m.h ../config/s.h fail.h misc.h mlvalues.h \ + freelist.h gc.h gc_ctrl.h major_gc.h roots.h +memory.d.o : memory.c fail.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + freelist.h gc.h gc_ctrl.h major_gc.h memory.h minor_gc.h +meta.d.o : meta.c alloc.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + interp.h major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h +minor_gc.d.o : minor_gc.c config.h ../config/m.h ../config/s.h fail.h misc.h mlvalues.h \ + gc.h gc_ctrl.h major_gc.h freelist.h memory.h minor_gc.h roots.h +misc.d.o : misc.c config.h ../config/m.h ../config/s.h misc.h +parsing.d.o : parsing.c config.h ../config/m.h ../config/s.h mlvalues.h misc.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h alloc.h +prims.d.o : prims.c mlvalues.h config.h ../config/m.h ../config/s.h misc.h prims.h +roots.d.o : roots.c memory.h config.h ../config/m.h ../config/s.h gc.h mlvalues.h \ + misc.h major_gc.h freelist.h minor_gc.h roots.h stacks.h +signals.d.o : signals.c alloc.h misc.h config.h ../config/m.h ../config/s.h mlvalues.h \ + fail.h interp.h memory.h gc.h major_gc.h freelist.h minor_gc.h roots.h signals.h +stacks.d.o : stacks.c config.h ../config/m.h ../config/s.h fail.h misc.h mlvalues.h \ + stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.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 mlvalues.h \ + fail.h instruct.h signals.h stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h +terminfo.d.o : terminfo.c config.h ../config/m.h ../config/s.h alloc.h misc.h \ + mlvalues.h fail.h io.h diff --git a/byterun/Makefile b/byterun/Makefile new file mode 100644 index 0000000000..2ac4f0ef3a --- /dev/null +++ b/byterun/Makefile @@ -0,0 +1,84 @@ +include ../config/Makefile.h +include ../Makefile.config + +CFLAGS=-O $(CCCOMPOPTS) +DFLAGS=-g -DDEBUG $(CCCOMPOPTS) + +OBJS=interp.o misc.o stacks.o fix_code.o main.o fail.o signals.o \ + freelist.o major_gc.o minor_gc.o memory.o alloc.o roots.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 lexing.o gc_ctrl.o terminfo.o crc.o + +DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o + +PRIMS=array.c compare.c crc.c extern.c floats.c gc_ctrl.c hash.c \ + intern.c interp.c ints.c io.c lexing.c meta.c parsing.c \ + signals.c str.c sys.c terminfo.c + +all: camlrun camlrund libcaml.a + +camlrun: $(OBJS) prims.o + $(CC) $(CCCOMPOPTS) $(CCLINKOPTS) $(LOWADDRESSES) -o camlrun prims.o $(OBJS) $(CCLIBS) + +camlrund: $(DOBJS) prims.o + $(CC) -g $(CCCOMPOPTS) $(CCLINKOPTS) $(LOWADDRESSES) -o camlrund prims.o $(DOBJS) $(CCLIBS) + +libcaml.a: $(OBJS) + rm -f libcaml.a + ar rc libcaml.a $(OBJS) + $(RANLIB) libcaml.a + +install: + cp camlrun $(BINDIR)/cslrun + cp libcaml.a $(LIBDIR) + $(RANLIB) $(LIBDIR)/libcaml.a + test -d $(LIBDIR)/caml || mkdir $(LIBDIR)/caml + cp mlvalues.h alloc.h misc.h $(LIBDIR)/caml + sed -e '/#include ".*\/m.h/r ../config/m.h' \ + -e '/#include ".*\/s.h/r ../config/s.h' \ + -e '/#include "/d' config.h > $(LIBDIR)/caml/config.h + sed -e '/#include ".*gc\.h"/d' \ + -e '/#define Alloc_small/,/^}/d' \ + -e '/Modify/,/^}/d' memory.h > $(LIBDIR)/caml/memory.h + +clean: + rm -f camlrun camlrund *.o *.a + rm -f primitives prims.c opnames.h jumptbl.h + +primitives : $(PRIMS) + sed -n -e '/\/\* ML \*\//s/.* \([a-z0-9_]*\)(.*/\1/p' \ + $(PRIMS) > primitives + +prims.c : primitives + (echo '#include "mlvalues.h"'; \ + echo '#include "prims.h"'; \ + sed -e 's/.*/extern value &();/' primitives; \ + echo 'c_primitive cprim[] = {'; \ + sed -e 's/.*/ &,/' primitives; \ + echo ' 0 };'; \ + echo 'char * names_of_cprim[] = {'; \ + sed -e 's/.*/ "&",/' primitives; \ + echo ' 0 };') > prims.c + +opnames.h : instruct.h + sed -e '/\/\*/d' \ + -e 's/enum /char * names_of_/' \ + -e 's/{$$/[] = {/' \ + -e 's/\([A-Z][A-Z_0-9]*\)/"\1"/g' instruct.h > opnames.h + +# jumptbl.h is required only if you have GCC 2.0 or later +jumptbl.h : instruct.h + sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ + -e '/^}/q' instruct.h > jumptbl.h + +.SUFFIXES: .d.o + +.c.d.o: + cd .debugobj; $(CC) -c $(DFLAGS) -I.. ../$< + mv .debugobj/$*.o $*.d.o + +depend : prims.c opnames.h jumptbl.h + gcc -MM $(CFLAGS) *.c > .depend + gcc -MM $(DFLAGS) *.c | sed -e 's/\.o/.d.o/' >> .depend + +include .depend diff --git a/byterun/alloc.c b/byterun/alloc.c new file mode 100644 index 0000000000..afe0892cee --- /dev/null +++ b/byterun/alloc.c @@ -0,0 +1,131 @@ +/* 1. Allocation functions doing the same work as the macros in the + case where [Setup_for_gc] and [Restore_after_gc] are no-ops. + 2. Convenience functions related to allocation. +*/ + +#include <string.h> +#include "alloc.h" +#include "major_gc.h" +#include "memory.h" +#include "mlvalues.h" +#include "stacks.h" + +#define Setup_for_gc +#define Restore_after_gc + +value alloc (wosize, tag) + mlsize_t wosize; + tag_t tag; +{ + value result; + + Assert (wosize > 0 && wosize <= Max_young_wosize); + Alloc_small (result, wosize, tag); + return result; +} + +value alloc_tuple(n) + mlsize_t n; +{ + return alloc(n, 0); +} + +value alloc_string (len) + mlsize_t len; +{ + value result; + mlsize_t offset_index; + mlsize_t wosize = (len + sizeof (value)) / sizeof (value); + + if (wosize <= Max_young_wosize) { + Alloc_small (result, wosize, String_tag); + }else{ + result = alloc_shr (wosize, String_tag); + } + Field (result, wosize - 1) = 0; + offset_index = Bsize_wsize (wosize) - 1; + Byte (result, offset_index) = offset_index - len; + return result; +} + +value alloc_final (len, fun, mem, max) + mlsize_t len; + final_fun fun; + mlsize_t mem, max; +{ + value result = alloc_shr (len, Final_tag); + + Field (result, 0) = (value) fun; + adjust_gc_speed (mem, max); + return result; +} + +value copy_double(d) + double d; +{ + value res; + + Alloc_small(res, Double_wosize, Double_tag); + Store_double_val(res, d); + return res; +} + +value copy_string(s) + char * s; +{ + int len; + value res; + + len = strlen(s); + res = alloc_string(len); + bcopy(s, String_val(res), len); + return res; +} + +value alloc_array(funct, arr) + value (*funct) P((char *)); + char ** arr; +{ + mlsize_t nbr, n; + value v; + + nbr = 0; + while (arr[nbr] != 0) nbr++; + if (nbr == 0) { + v = Atom(0); + } else { + while (extern_sp - nbr <= stack_low) + realloc_stack(); + for (n = 0; n < nbr; n++) + *--extern_sp = funct(arr[n]); + if (nbr < Max_young_wosize) { + v = alloc(nbr, 0); + n = nbr; + while (n-- > 0) Field (v, n) = *extern_sp++; + } else { + v = alloc_shr(nbr, 0); + n = nbr; + while (n-- > 0) initialize (&Field(v, n), *extern_sp++); + } + } + return v; +} + +value copy_string_array(arr) + char ** arr; +{ + return alloc_array(copy_string, arr); +} + +int convert_flag_list(list, flags) + value list; + int * flags; +{ + int res; + res = 0; + while (Tag_val(list) == 1) { + res |= flags[Tag_val(Field(list, 0))]; + list = Field(list, 1); + } + return res; +} diff --git a/byterun/alloc.h b/byterun/alloc.h new file mode 100644 index 0000000000..5b0a1029a0 --- /dev/null +++ b/byterun/alloc.h @@ -0,0 +1,19 @@ +#ifndef _alloc_ +#define _alloc_ + + +#include "misc.h" +#include "mlvalues.h" + +value alloc P((mlsize_t, tag_t)); +value alloc_tuple P((mlsize_t)); +value alloc_string P((mlsize_t)); +value alloc_final P((mlsize_t, final_fun, mlsize_t, mlsize_t)); +value copy_string P((char *)); +value copy_string_array P((char **)); +value copy_double P((double)); +value alloc_array P((value (*funct) P((char *)), char ** array)); +int convert_flag_list P((value, int *)); + + +#endif /* _alloc_ */ diff --git a/byterun/array.c b/byterun/array.c new file mode 100644 index 0000000000..471bfa1541 --- /dev/null +++ b/byterun/array.c @@ -0,0 +1,45 @@ +/* Operations on arrays */ + +#include "alloc.h" +#include "fail.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" + +value make_vect(len, init) /* ML */ + value len, init; +{ + value res; + mlsize_t size, i; + Push_roots(root, 1); + + size = Long_val(len); + if (size > Max_wosize) { + Pop_roots(); + invalid_argument("Array.new"); + } + if (size == 0) { + res = Atom(0); + } + else if (size < Max_young_wosize) { + root[0] = init; + res = alloc(size, 0); + init = root[0]; + for (i = 0; i < size; i++) Field(res, i) = init; + } + else if (Is_block(init) && Is_young(init)) { + root[0] = init; + minor_collection(); + res = alloc_shr(size, 0); + init = root[0]; + for (i = 0; i < size; i++) Field(res, i) = init; + } + else { + root[0] = init; + res = alloc_shr(size, 0); + init = root[0]; + for (i = 0; i < size; i++) initialize(&Field(res, i), init); + } + Pop_roots(); + return res; +} diff --git a/byterun/compare.c b/byterun/compare.c new file mode 100644 index 0000000000..a42fe7664d --- /dev/null +++ b/byterun/compare.c @@ -0,0 +1,110 @@ +#include "fail.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "str.h" + +/* Structural comparison on trees. + May loop on cyclic structures. */ + +static long compare_val(v1, v2) + value v1,v2; +{ + tag_t t1, t2; + + tailcall: + if (v1 == v2) return 0; + if (Is_long(v1) || Is_long(v2)) return Long_val(v1) - Long_val(v2); + /* If one of the objects is outside the heap (but is not an atom), + use address comparison. */ + if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap(v1)) || + (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap(v2))) + return v1 - v2; + t1 = Tag_val(v1); + t2 = Tag_val(v2); + if (t1 != t2) return (long)t1 - (long)t2; + switch(t1) { + case String_tag: { + mlsize_t len1, len2, len; + unsigned char * p1, * p2; + len1 = string_length(v1); + len2 = string_length(v2); + for (len = (len1 <= len2 ? len1 : len2), + p1 = (unsigned char *) String_val(v1), + p2 = (unsigned char *) String_val(v2); + len > 0; + len--, p1++, p2++) + if (*p1 != *p2) return (long)*p1 - (long)*p2; + return len1 - len2; + } + case Double_tag: { + double d1 = Double_val(v1); + double d2 = Double_val(v2); + if (d1 == d2) return 0; else if (d1 < d2) return -1; else return 1; + } + case Abstract_tag: + case Final_tag: + invalid_argument("equal: abstract value"); + case Closure_tag: + invalid_argument("equal: functional value"); + default: { + mlsize_t sz1 = Wosize_val(v1); + mlsize_t sz2 = Wosize_val(v2); + value * p1, * p2; + long res; + if (sz1 != sz2) return sz1 - sz2; + for(p1 = Op_val(v1), p2 = Op_val(v2); + sz1 > 1; + sz1--, p1++, p2++) { + res = compare_val(*p1, *p2); + if (res != 0) return res; + } + v1 = *p1; + v2 = *p2; + goto tailcall; + } + } +} + +value compare(v1, v2) /* ML */ + value v1, v2; +{ + return Val_long(compare_val(v1, v2)); +} + +value equal(v1, v2) /* ML */ + value v1, v2; +{ + return Atom(compare_val(v1, v2) == 0); +} + +value notequal(v1, v2) /* ML */ + value v1, v2; +{ + return Atom(compare_val(v1, v2) != 0); +} + +value lessthan(v1, v2) /* ML */ + value v1, v2; +{ + return Atom(compare_val(v1, v2) < 0); +} + +value lessequal(v1, v2) /* ML */ + value v1, v2; +{ + return Atom(compare_val(v1, v2) <= 0); +} + +value greaterthan(v1, v2) /* ML */ + value v1, v2; +{ + return Atom(compare_val(v1, v2) > 0); +} + +value greaterequal(v1, v2) /* ML */ + value v1, v2; +{ + return Atom(compare_val(v1, v2) >= 0); +} + diff --git a/byterun/config.h b/byterun/config.h new file mode 100644 index 0000000000..c3a8a78b91 --- /dev/null +++ b/byterun/config.h @@ -0,0 +1,121 @@ +#ifndef _config_ +#define _config_ + + +#include "../config/m.h" +#include "../config/s.h" + +/* Library dependencies */ + +#ifdef HAS_MEMMOVE +#define bcopy(src,dst,len) memmove((dst), (src), (len)) +#else +#ifdef HAS_BCOPY +/* Nothing to do */ +#else +#ifdef HAS_MEMCPY +#define bcopy(src,dst,len) memcpy((dst), (src), (len)) +#else +#define bcopy(src,dst,len) memmov((dst), (src), (len)) +#define USING_MEMMOV +#endif +#endif +#endif + +#ifndef HAS__SETJMP +#define _setjmp setjmp +#define _longjmp longjmp +#endif + +/* We use threaded code interpretation if the compiler provides labels + as first-class values (GCC 2.x). */ + +#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) +#define THREADED_CODE +#endif + +/* Do not change this definition. */ +#define Page_size (1 << Page_log) + +/* Memory model parameters */ + +#ifndef SMALL + +/* The size of a page for memory management (in bytes) is [1 << Page_log]. + It must be a multiple of [sizeof (long)]. */ +#define Page_log 12 /* A page is 4 kilobytes. */ + +/* Initial sizes of stack (bytes). */ +#define Stack_size 16384 + +/* Minimum free size of stack (bytes); below that, it is reallocated. */ +#define Stack_threshold 1024 + +/* Maximum sizes for the stack (bytes). */ + +#ifdef MINIMIZE_MEMORY +#define Max_stack_size 131072 +#else +#define Max_stack_size 524288 +#endif + +/* Maximum size of a block allocated in the young generation (words). */ +/* Must be > 4 */ +#define Max_young_wosize 256 + + +/* Minimum size of the minor zone (words). + This must be at least [Max_young_wosize + 1]. */ +#define Minor_heap_min 4096 + +/* Maximum size of the minor zone (words). + Must be greater than or equal to [Minor_heap_min]. +*/ +#define Minor_heap_max (1 << 28) + +/* Default size of the minor zone. (words) */ +#define Minor_heap_def 32768 + + +/* Minimum size increment when growing the heap (words). + Must be a multiple of [Page_size / sizeof (value)]. */ +#define Heap_chunk_min (2 * Page_size / sizeof (value)) + +/* Maximum size of a contiguous piece of the heap (words). + Must be greater than or equal to [Heap_chunk_min]. + Must be greater than or equal to [Bhsize_wosize (Max_wosize)]. */ +#define Heap_chunk_max (Bhsize_wosize (Max_wosize)) + +/* Default size increment when growing the heap. (bytes) + Must be a multiple of [Page_size / sizeof (value)]. */ +#define Heap_chunk_def (62 * Page_size / sizeof (value)) + + +/* Default speed setting for the major GC. The heap will grow until + the dead objects and the free list represent this percentage of the + heap size. The rest of the heap is live objects. */ +#define Percent_free_def 30 + +#else +/* Scaled-down parameters for small memory */ + +#define Page_log 10 +#define Arg_stack_size 16384 +#define Ret_stack_size 16384 +#define Arg_stack_threshold 1024 +#define Ret_stack_threshold 1024 +#define Max_arg_stack_size 524288 +#define Max_ret_stack_size 524288 +#define Max_young_wosize 256 +#define Minor_heap_min 1024 +#define Minor_heap_max (1 << 28) +#define Minor_heap_def 16384 +#define Heap_chunk_min (2 * Page_size / sizeof (value)) +#define Heap_chunk_max (1 << 28) +#define Heap_chunk_def (126 * Page_size / sizeof (value)) +#define Percent_free_def 20 + +#endif + + +#endif /* _config_ */ diff --git a/byterun/crc.c b/byterun/crc.c new file mode 100644 index 0000000000..0e961b3493 --- /dev/null +++ b/byterun/crc.c @@ -0,0 +1,91 @@ +/* CRC computation */ + +#include "io.h" +#include "mlvalues.h" + +static uint32 crc32tab[] = { /* CRC polynomial 0xedb88320 */ + 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, + 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, + 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, + 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de, + 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856, + 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9, + 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, + 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, + 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, + 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, + 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, + 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, + 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, + 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, + 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, + 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, + 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, + 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, + 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, + 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, + 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, + 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, + 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, + 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, + 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, + 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, + 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, + 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, + 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, + 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, + 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, + 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, + 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, + 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, + 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, + 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, + 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, + 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, + 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, + 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, + 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, + 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, + 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, + 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, + 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, + 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, + 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, + 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, + 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, + 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, + 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, + 0x2d02ef8d }; + +#define START 0xFFFFFFFF +#define MASK_RESULT 0x7FFFFFFF + +/* This macro assumes that crc is an unsigned integer */ +#define ADDCRC(ch, crc) (crc32tab[((ch) ^ crc) & 0xff] ^ (crc >> 8)) + +value crc_string(str, ofs, len) /* ML */ + value str, ofs, len; +{ + unsigned char * p; + mlsize_t n; + uint32 crc; + + for (crc = START, p = &Byte_u(str, Long_val(ofs)), n = Long_val(len); + n > 0; + n--, p++) + crc = ADDCRC(*p, crc); + return Val_int(crc & MASK_RESULT); +} + +value crc_chan(chan, len) /* ML */ + struct channel * chan; + value len; +{ + mlsize_t n; + uint32 crc; + + for (crc = START, n = Long_val(len); n > 0; n--) + crc = ADDCRC(getch(chan), crc); + return Val_int(crc & MASK_RESULT); +} + diff --git a/byterun/exec.h b/byterun/exec.h new file mode 100644 index 0000000000..1590dc0a4a --- /dev/null +++ b/byterun/exec.h @@ -0,0 +1,27 @@ +/* exec.h : format of executable bytecode files */ + +/* offset 0 ---> initial junk + code block + data block + symbol table + debug infos + trailer + end of file ---> +*/ + +/* Structure of the trailer: four 32-bit, unsigned integers, big endian */ + +#define TRAILER_SIZE (4*4+12) + +struct exec_trailer { + unsigned long code_size; /* Size of the code block (in bytes) */ + unsigned long data_size; /* Size of the global data table (bytes) */ + unsigned long symbol_size; /* Size of the symbol table (bytes) */ + unsigned long debug_size; /* Size of the debug infos (bytes) */ + char magic[12]; /* A magic string */ +}; + +/* Magic number for this release */ + +#define EXEC_MAGIC "Caml1999X001" + diff --git a/byterun/extern.c b/byterun/extern.c new file mode 100644 index 0000000000..ea05d35e76 --- /dev/null +++ b/byterun/extern.c @@ -0,0 +1,245 @@ +/* Structured output */ + +#include "fail.h" +#include "gc.h" +#include "intext.h" +#include "io.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "reverse.h" +#include "str.h" + +/* To keep track of sharing in externed objects */ + +typedef unsigned long byteoffset_t; + +struct extern_obj { + value obj; + byteoffset_t ofs; +}; + +static struct extern_obj * extern_table; +static asize_t extern_table_size; + +#ifdef SIXTYFOUR +#define Hash(v) (((asize_t) ((v) >> 3)) % extern_table_size) +#else +#define Hash(v) (((asize_t) ((v) >> 2)) % extern_table_size) +#endif + +static void alloc_extern_table() +{ + asize_t i; + + extern_table = (struct extern_obj *) + stat_alloc(extern_table_size * sizeof(struct extern_obj)); + for (i = 0; i < extern_table_size; i++) + extern_table[i].obj = 0; +} + +static void resize_extern_table() +{ + asize_t oldsize; + struct extern_obj * oldtable; + asize_t i, h; + + oldsize = extern_table_size; + oldtable = extern_table; + extern_table_size = 2 * extern_table_size; + alloc_extern_table(); + for (i = 0; i < oldsize; i++) { + h = Hash(oldtable[i].obj); + while (extern_table[h].obj != 0) { + h++; + if (h >= extern_table_size) h = 0; + } + extern_table[h].obj = oldtable[i].obj; + extern_table[h].ofs = oldtable[i].ofs; + } + stat_free((char *) oldtable); +} + +/* Write integers on a channel */ + +static void output8(chan, code, val) + struct channel * chan; + int code; + long val; +{ + putch(chan, code); putch(chan, val); +} + +static void output16(chan, code, val) + struct channel * chan; + int code; + long val; +{ + putch(chan, code); putch(chan, val >> 8); putch(chan, val); +} + +static void output32(chan, code, val) + struct channel * chan; + int code; + long val; +{ + putch(chan, code); + putch(chan, val >> 24); putch(chan, val >> 16); + putch(chan, val >> 8); putch(chan, val); +} + +#ifdef SIXTYFOUR +static void output64(chan, code, val) + struct channel * chan; + int code; + long val; +{ + int i; + putch(chan, code); + for (i = 64 - 8; i >= 0; i -= 8) putch(chan, val >> i); +} +#endif + +static byteoffset_t obj_counter; /* Number of objects emitted so far */ +static unsigned long size_32; /* Size in words of 32-bit block for struct. */ +static unsigned long size_64; /* Size in words of 64-bit block for struct. */ + +static void emit_compact(chan, v) + struct channel * chan; + value v; +{ + tailcall: + if (Is_long(v)) { + long n = Long_val(v); + if (n >= 0 && n < 0x40) { + putch(chan, PREFIX_SMALL_INT + n); + } else if (n >= -(1 << 7) && n < (1 << 7)) { + output8(chan, CODE_INT8, n); + } else if (n >= -(1 << 15) && n < (1 << 15)) { + output16(chan, CODE_INT16, n); +#ifdef SIXTYFOUR + } else if (n < -(1L << 31) || n >= (1L << 31)) { + output64(chan, CODE_INT64, n); +#endif + } else + output32(chan, CODE_INT32, n); + } else { + header_t hd = Hd_val(v); + tag_t tag = Tag_hd(hd); + mlsize_t sz = Wosize_hd(hd); + asize_t h; + /* Atoms are treated specially for two reasons: they are not allocated + in the externed block, and they are automatically shared. */ + if (sz == 0) { + if (tag < 16) { + putch(chan, PREFIX_SMALL_BLOCK + tag); + } else { + output32(chan, CODE_BLOCK32, hd); + } + } else { + /* Check if already seen */ + if (2 * obj_counter >= extern_table_size) resize_extern_table(); + h = Hash(v); + while (extern_table[h].obj != 0) { + if (extern_table[h].obj == v) { + byteoffset_t d = obj_counter - extern_table[h].ofs; + if (d < 0x100) { + output8(chan, CODE_SHARED8, d); + } else if (d < 0x10000) { + output16(chan, CODE_SHARED16, d); + } else { + output32(chan, CODE_SHARED32, d); + } + return; + } + h++; + if (h >= extern_table_size) h = 0; + } + /* Not seen yet. Record the object and output its contents. */ + extern_table[h].obj = v; + extern_table[h].ofs = obj_counter; + obj_counter++; + switch(tag) { + case String_tag: { + mlsize_t len = string_length(v); + if (len < 0x20) { + putch(chan, PREFIX_SMALL_STRING + len); + } else if (len < 0x100) { + output8(chan, CODE_STRING8, len); + } else { + output32(chan, CODE_STRING32, len); + } + putblock(chan, String_val(v), len); + size_32 += 1 + (len + 4) / 4; + size_64 += 1 + (len + 8) / 8; + break; + } + case Double_tag: { + double buffer; + if (sizeof(double) != 8) + invalid_argument("output_value: non-standard floats"); + putch(chan, CODE_DOUBLE_NATIVE); + buffer = Double_val(v); + putblock(chan, (char *) &buffer, 8); + size_32 += 1 + sizeof(double) / 4; + size_64 += 1 + sizeof(double) / 8; + break; + } + case Abstract_tag: + case Final_tag: + invalid_argument("output_value: abstract value"); + break; + case Closure_tag: + invalid_argument("output_value: functional value"); + break; + default: { + mlsize_t i; + if (tag < 16 && sz < 8) { + putch(chan, PREFIX_SMALL_BLOCK + tag + (sz << 4)); + } else { + output32(chan, CODE_BLOCK32, hd); + } + size_32 += 1 + sz; + size_64 += 1 + sz; + for (i = 0; i < sz - 1; i++) emit_compact(chan, Field(v, i)); + v = Field(v, i); + goto tailcall; + } + } + } + } +} + +value output_value(chan, v) /* ML */ + struct channel * chan; + value v; +{ + value start_loc, final_loc; + putword(chan, Compact_magic_number); + start_loc = pos_out(chan); + putword(chan, 0); + putword(chan, 0); + putword(chan, 0); + extern_table_size = INITIAL_EXTERN_TABLE_SIZE; + alloc_extern_table(); + obj_counter = 0; + size_32 = 0; + size_64 = 0; + emit_compact(chan, v); +#ifdef SIXTYFOUR + if (size_32 >= (1L << 32) || size_64 >= (1L << 32)) { + /* The object is so big its size cannot be written in the header. + Besides, some of the block sizes or string lengths or shared offsets + it contains may have overflowed the 32 bits used to write them. */ + failwith("output_value: object too big"); + } +#endif + final_loc = pos_out(chan); + seek_out(chan, start_loc); + putword(chan, obj_counter); + putword(chan, size_32); + putword(chan, size_64); + seek_out(chan, final_loc); + stat_free((char *) extern_table); + return Val_unit; +} diff --git a/byterun/fail.c b/byterun/fail.c new file mode 100644 index 0000000000..8b56034beb --- /dev/null +++ b/byterun/fail.c @@ -0,0 +1,108 @@ +/* Raising exceptions from C. */ + +#include "alloc.h" +#include "fail.h" +#include "gc.h" +#include "memory.h" +#include "mlvalues.h" +#include "signals.h" +#include "stacks.h" + +struct longjmp_buffer * external_raise; +value exn_bucket; + +static void mlraise P((value)) Noreturn; + +static void mlraise(v) + value v; +{ + leave_blocking_section(); + exn_bucket = v; + longjmp(external_raise->buf, 1); +} + +void raise_constant(tag) + value tag; +{ + value bucket; + Push_roots (a, 1); + a[0] = tag; + bucket = alloc (1, 0); + Field(bucket, 0) = a[0]; + Pop_roots (); + mlraise(bucket); +} + +void raise_with_arg(tag, arg) + value tag; + value arg; +{ + value bucket; + Push_roots (a, 2); + a[0] = tag; + a[1] = arg; + bucket = alloc (2, 0); + Field(bucket, 0) = a[0]; + Field(bucket, 1) = a[1]; + Pop_roots (); + mlraise(bucket); +} + +void raise_with_string(tag, msg) + value tag; + char * msg; +{ + raise_with_arg(tag, copy_string(msg)); +} + +void failwith (msg) + char * msg; +{ + raise_with_string(Field(global_data, FAILURE_EXN), msg); +} + +void invalid_argument (msg) + char * msg; +{ + raise_with_string(Field(global_data, INVALID_EXN), msg); +} + +/* Problem: we can't use raise_constant, because it allocates and + we're out of memory... The following is a terrible hack that works + because global_data[OUT_OF_MEMORY_EXN] is in the old generation + (because global_data was read with intern_val), hence stays at + a fixed address */ + +static struct { + header_t hdr; + value exn; +} out_of_memory_bucket; + +void raise_out_of_memory() +{ + out_of_memory_bucket.hdr = Make_header(1, 0, White); + out_of_memory_bucket.exn = Field(global_data, OUT_OF_MEMORY_EXN); + mlraise((value) &(out_of_memory_bucket.exn)); +} + +void raise_sys_error(msg) + value msg; +{ + raise_with_arg(Field(global_data, SYS_ERROR_EXN), msg); +} + +void raise_end_of_file() +{ + raise_constant(Field(global_data, END_OF_FILE_EXN)); +} + +void raise_zero_divide() +{ + raise_constant(Field(global_data, ZERO_DIVIDE_EXN)); +} + +void raise_not_found() +{ + raise_constant(Field(global_data, NOT_FOUND_EXN)); +} + diff --git a/byterun/fail.h b/byterun/fail.h new file mode 100644 index 0000000000..0a0be89706 --- /dev/null +++ b/byterun/fail.h @@ -0,0 +1,36 @@ +#ifndef _fail_ +#define _fail_ + + +#include <setjmp.h> +#include "misc.h" +#include "mlvalues.h" + +#define OUT_OF_MEMORY_EXN 0 /* "Out_of_memory" */ +#define SYS_ERROR_EXN 1 /* "Sys_error" */ +#define FAILURE_EXN 2 /* "Failure" */ +#define INVALID_EXN 3 /* "Invalid_argument" */ +#define END_OF_FILE_EXN 4 /* "End_of_file" */ +#define ZERO_DIVIDE_EXN 5 /* "Division_by_zero" */ +#define NOT_FOUND_EXN 6 /* "Not_found" */ +#define MATCH_FAILURE_EXN 7 /* "Match_failure" */ + +struct longjmp_buffer { + jmp_buf buf; +}; + +extern struct longjmp_buffer * external_raise; +extern value exn_bucket; + +void raise_constant P((value tag)) Noreturn; +void raise_with_arg P((value tag, value arg)) Noreturn; +void raise_with_string P((value tag, char * msg)) Noreturn; +void failwith P((char *)) Noreturn; +void invalid_argument P((char *)) Noreturn; +void raise_out_of_memory P((void)) Noreturn; +void raise_sys_error P((value)) Noreturn; +void raise_end_of_file P((void)) Noreturn; +void raise_zero_divide P((void)) Noreturn; +void raise_not_found P((void)) Noreturn; + +#endif /* _fail_ */ diff --git a/byterun/fix_code.c b/byterun/fix_code.c new file mode 100644 index 0000000000..9c24de180e --- /dev/null +++ b/byterun/fix_code.c @@ -0,0 +1,66 @@ +/* Translate a block of bytecode (endianness switch, threading). */ + +#include "config.h" +#include "fix_code.h" +#include "misc.h" +#include "mlvalues.h" +#include "instruct.h" +#include "reverse.h" + +/* This code is needed only if the processor is big endian */ + +#ifdef BIG_ENDIAN + +void fixup_endianness(code, len) + code_t code; + asize_t len; +{ + code_t p; + len /= sizeof(opcode_t); + for (p = code; p < code + len; p++) { + Reverse_int32(p); + } +} + +#endif + +/* This code is needed only if we're using threaded code */ + +#ifdef THREADED_CODE + +void thread_code(code, len, instr_table) + code_t code; + asize_t len; + void * instr_table[]; +{ + code_t p; + len /= sizeof(opcode_t); + for (p = code; p < code + len; /*nothing*/) { + opcode_t instr = *p; + Assert(instr >= 0 && instr <= STOP); + *p++ = (opcode_t)((unsigned long)(instr_table[instr])); + switch(instr) { + /* Instructions with one operand */ + case PUSHACC: case ACC: case POP: case ASSIGN: + case PUSHENVACC: case ENVACC: case PUSH_RETADDR: case APPLY: + case APPTERM1: case APPTERM2: case APPTERM3: case RETURN: + case GRAB: case PUSHGETGLOBAL: case GETGLOBAL: case SETGLOBAL: + case PUSHATOM: case ATOM: case MAKEBLOCK1: case MAKEBLOCK2: + case MAKEBLOCK3: case GETFIELD: case SETFIELD: case DUMMY: + case BRANCH: case BRANCHIF: case BRANCHIFNOT: case PUSHTRAP: + case C_CALL1: case C_CALL2: case C_CALL3: case C_CALL4: + case CONSTINT: case PUSHCONSTINT: case OFFSETINT: case OFFSETREF: + p += 1; break; + /* Instructions with two operands */ + case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD: + case GETGLOBALFIELD: case MAKEBLOCK: case C_CALLN: + p += 2; break; + /* Instructions with N+1 operands */ + case SWITCH: case TRANSLATE: + p += *p + 1; break; + } + } + Assert(p = code + len); +} + +#endif diff --git a/byterun/fix_code.h b/byterun/fix_code.h new file mode 100644 index 0000000000..c754fad278 --- /dev/null +++ b/byterun/fix_code.h @@ -0,0 +1,15 @@ +/* Translate a block of bytecode (endianness switch, threading). */ + +#ifndef _fix_code_ +#define _fix_code_ + + +#include "misc.h" +#include "mlvalues.h" + +void fixup_endianness P((code_t code, asize_t len)); +void thread_code P((code_t code, asize_t len, void * instr_table[])); + + +#endif + diff --git a/byterun/floats.c b/byterun/floats.c new file mode 100644 index 0000000000..f5b4864737 --- /dev/null +++ b/byterun/floats.c @@ -0,0 +1,226 @@ +#include <math.h> +#include <stdio.h> +#include <stdlib.h> +#include "alloc.h" +#include "fail.h" +#include "memory.h" +#include "mlvalues.h" +#include "misc.h" +#include "stacks.h" + +#ifdef ALIGN_DOUBLE + +double Double_val(val) + value val; +{ + union { value v[2]; double d; } buffer; + + Assert(sizeof(double) == 2 * sizeof(value)); + buffer.v[0] = Field(val, 0); + buffer.v[1] = Field(val, 1); + return buffer.d; +} + +void Store_double_val(val, dbl) + value val; + double dbl; +{ + union { value v[2]; double d; } buffer; + + Assert(sizeof(double) == 2 * sizeof(value)); + buffer.d = dbl; + Field(val, 0) = buffer.v[0]; + Field(val, 1) = buffer.v[1]; +} + +#endif + +value format_float(fmt, arg) /* ML */ + value fmt, arg; +{ + char format_buffer[64]; + int prec, i; + char * p; + char * dest; + value res; + + prec = 64; + for (p = String_val(fmt); *p != 0; p++) { + if (*p >= '0' && *p <= '9') { + i = atoi(p) + 15; + if (i > prec) prec = i; + break; + } + } + for( ; *p != 0; p++) { + if (*p == '.') { + i = atoi(p+1) + 15; + if (i > prec) prec = i; + break; + } + } + if (prec <= sizeof(format_buffer)) { + dest = format_buffer; + } else { + dest = stat_alloc(prec); + } + sprintf(dest, String_val(fmt), Double_val(arg)); + res = copy_string(dest); + if (dest != format_buffer) { + stat_free(dest); + } + return res; +} + +value float_of_string(s) /* ML */ + value s; +{ + return copy_double(atof(String_val(s))); +} + +value int_of_float(f) /* ML */ + value f; +{ + return Val_long((long) Double_val(f)); +} + +value float_of_int(n) /* ML */ + value n; +{ + return copy_double((double) Long_val(n)); +} + +value neg_float(f) /* ML */ + value f; +{ + return copy_double(- Double_val(f)); +} + +value add_float(f, g) /* ML */ + value f, g; +{ + return copy_double(Double_val(f) + Double_val(g)); +} + +value sub_float(f, g) /* ML */ + value f, g; +{ + return copy_double(Double_val(f) - Double_val(g)); +} + +value mul_float(f, g) /* ML */ + value f, g; +{ + return copy_double(Double_val(f) * Double_val(g)); +} + +value div_float(f, g) /* ML */ + value f, g; +{ + double dg = Double_val(g); + if (dg == 0.0) raise_zero_divide(); + return copy_double(Double_val(f) / dg); +} + +value exp_float(f) /* ML */ + value f; +{ + return copy_double(exp(Double_val(f))); +} + +value log_float(f) /* ML */ + value f; +{ + return copy_double(log(Double_val(f))); +} + +value sqrt_float(f) /* ML */ + value f; +{ + return copy_double(sqrt(Double_val(f))); +} + +value power_float(f, g) /* ML */ + value f, g; +{ + return copy_double(pow(Double_val(f), Double_val(g))); +} + +value sin_float(f) /* ML */ + value f; +{ + return copy_double(sin(Double_val(f))); +} + +value cos_float(f) /* ML */ + value f; +{ + return copy_double(cos(Double_val(f))); +} + +value tan_float(f) /* ML */ + value f; +{ + return copy_double(tan(Double_val(f))); +} + +value asin_float(f) /* ML */ + value f; +{ + return copy_double(asin(Double_val(f))); +} + +value acos_float(f) /* ML */ + value f; +{ + return copy_double(acos(Double_val(f))); +} + +value atan_float(f) /* ML */ + value f; +{ + return copy_double(atan(Double_val(f))); +} + +value atan2_float(f, g) /* ML */ + value f, g; +{ + return copy_double(atan2(Double_val(f), Double_val(g))); +} + +value eq_float(f, g) /* ML */ + value f, g; +{ + return Val_bool(Double_val(f) == Double_val(g)); +} + +value neq_float(f, g) /* ML */ + value f, g; +{ + return Val_bool(Double_val(f) != Double_val(g)); +} + +value le_float(f, g) /* ML */ + value f, g; +{ + return Val_bool(Double_val(f) <= Double_val(g)); +} + +value lt_float(f, g) /* ML */ + value f, g; +{ + return Val_bool(Double_val(f) < Double_val(g)); +} + +value ge_float(f, g) /* ML */ + value f, g; +{ + return Val_bool(Double_val(f) >= Double_val(g)); +} + +value gt_float(f, g) /* ML */ + value f, g; +{ + return Val_bool(Double_val(f) > Double_val(g)); +} + diff --git a/byterun/freelist.c b/byterun/freelist.c new file mode 100644 index 0000000000..0b348fd205 --- /dev/null +++ b/byterun/freelist.c @@ -0,0 +1,234 @@ +#include "config.h" +#include "freelist.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "misc.h" +#include "mlvalues.h" + +/* The free-list is kept sorted by increasing addresses. + This makes the merging of adjacent free blocks possible. + (See [fl_merge_block].) +*/ + +typedef struct { + char *next_bp; /* Pointer to the first byte of the next block. */ +} block; + +/* The sentinel can be located anywhere in memory, but it must not be + adjacent to any heap object. */ +static struct { + value filler1; /* Make sure the sentinel is never adjacent to any block. */ + header_t h; + value first_bp; + value filler2; /* Make sure the sentinel is never adjacent to any block. */ +} sentinel = {0, Make_header (0, 0, Blue), 0, 0}; + +#define Fl_head ((char *) (&(sentinel.first_bp))) +static char *fl_prev = Fl_head; /* Current allocation pointer. */ +static char *fl_last = NULL; /* Last block in the list. Only valid + just after fl_allocate returned NULL. */ +char *fl_merge = Fl_head; /* Current insertion pointer. Managed + jointly with [sweep_slice]. */ + +#define Next(b) (((block *) (b))->next_bp) + +#ifdef DEBUG +void fl_verify () +{ + char *cur, *prev; + int prev_found = 0, merge_found = 0; + + prev = Fl_head; + cur = Next (prev); + while (cur != NULL){ + Assert (Is_in_heap (cur)); + if (cur == fl_prev) prev_found = 1; + if (cur == fl_merge) merge_found = 1; + prev = cur; + cur = Next (prev); + } + Assert (prev_found || fl_prev == Fl_head); + Assert (merge_found || fl_merge == Fl_head); +} +#endif + +/* [allocate_block] is called by [fl_allocate]. Given a suitable free + block and the desired size, it allocates a new block from the free + block. There are three cases: + 0. The free block has the desired size. Detach the block from the + free-list and return it. + 1. The free block is 1 word longer than the desired size. Detach + the block from the free list. The remaining word cannot be linked: + turn it into an empty block (header only), and return the rest. + 2. The free block is big enough. Split it in two and return the right + block. + In all cases, the allocated block is right-justified in the free block: + it is located in the high-address words of the free block. This way, + the linking of the free-list does not change in case 2. +*/ +static char *allocate_block (wh_sz, prev, cur) + mlsize_t wh_sz; + char *prev, *cur; +{ + header_t h = Hd_bp (cur); + Assert (Whsize_hd (h) >= wh_sz); + if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */ + Next (prev) = Next (cur); + Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL); + if (fl_merge == cur) fl_merge = prev; +#ifdef DEBUG + fl_last = NULL; +#endif + /* In case 1, the following creates the empty block correctly. + In case 0, it gives an invalid header to the block. The function + calling [fl_allocate] will overwrite it. */ + Hd_op (cur) = Make_header (0, 0, White); + }else{ /* Case 2. */ + Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Blue); + } + fl_prev = prev; + return cur + Bosize_hd (h) - Bsize_wsize (wh_sz); +} + +/* [fl_allocate] does not set the header of the newly allocated block. + The calling function must do it before any GC function gets called. + [fl_allocate] returns a head pointer. +*/ +char *fl_allocate (wo_sz) + mlsize_t wo_sz; +{ + char *cur, *prev; + Assert (sizeof (char *) == sizeof (value)); + Assert (fl_prev != NULL); + Assert (wo_sz >= 1); + /* Search from [fl_prev] to the end of the list. */ + prev = fl_prev; + cur = Next (prev); + while (cur != NULL){ Assert (Is_in_heap (cur)); + if (Wosize_bp (cur) >= wo_sz){ + return allocate_block (Whsize_wosize (wo_sz), prev, cur); + } + prev = cur; + cur = Next (prev); + } + fl_last = prev; + /* Search from the start of the list to [fl_prev]. */ + prev = Fl_head; + cur = Next (prev); + while (prev != fl_prev){ + if (Wosize_bp (cur) >= wo_sz){ + return allocate_block (Whsize_wosize (wo_sz), prev, cur); + } + prev = cur; + cur = Next (prev); + } + /* No suitable block was found. */ + return NULL; +} + +void fl_init_merge () +{ + fl_merge = Fl_head; +} + +/* [fl_merge_block] returns the head pointer of the next block after [bp], + because merging blocks may change the size of [bp]. */ +char *fl_merge_block (bp) + char *bp; +{ + char *prev, *cur, *adj; + header_t hd = Hd_bp (bp); + +#ifdef DEBUG + { + mlsize_t i; + for (i = 0; i < Wosize_hd (hd); i++){ + Field (Val_bp (bp), i) = not_random (); + } + } +#endif + prev = fl_merge; + cur = Next (prev); + /* The sweep code makes sure that this is the right place to insert + this block: */ + Assert (prev < bp || prev == Fl_head); + Assert (cur > bp || cur == NULL); + + /* If [bp] and [cur] are adjacent, remove [cur] from the free-list + and merge them. */ + adj = bp + Bosize_hd (hd); + if (adj == Hp_bp (cur)){ + char *next_cur = Next (cur); + long cur_whsz = Whsize_bp (cur); + + Next (prev) = next_cur; + if (fl_prev == cur) fl_prev = prev; + hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Blue); + Hd_bp (bp) = hd; + adj = bp + Bosize_hd (hd); +#ifdef DEBUG + fl_last = NULL; + Next (cur) = (char *) not_random (); + Hd_bp (cur) = not_random (); +#endif + cur = next_cur; + } + /* If [prev] and [bp] are adjacent merge them, else insert [bp] into + the free-list if it is big enough. */ + if (prev + Bosize_bp (prev) == Hp_bp (bp)){ + Hd_bp (prev) = Make_header (Wosize_bp (prev) + Whsize_hd (hd), 0, Blue); +#ifdef DEBUG + Hd_bp (bp) = not_random (); +#endif + Assert (fl_merge == prev); + }else if (Wosize_hd (hd) > 0){ + Hd_bp (bp) = Bluehd_hd (hd); + Next (bp) = cur; + Next (prev) = bp; + fl_merge = bp; + } /* Else leave it in white. */ + return adj; +} + +/* This is a heap extension. We have to insert it in the right place + in the free-list. + [fl_add_block] can only be called just after a call to [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].) +*/ +void fl_add_block (bp) + 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) = not_random (); + } + } +#endif + if (bp > fl_last){ + Next (fl_last) = bp; + Next (bp) = NULL; + }else{ + char *cur, *prev; + + prev = Fl_head; + cur = Next (prev); + while (cur != NULL && cur < bp){ Assert (prev < bp || prev == Fl_head); + prev = cur; + cur = Next (prev); + } Assert (prev < bp || prev == Fl_head); + Assert (cur > bp || cur == NULL); + Next (bp) = cur; + Next (prev) = bp; + /* When inserting a block between fl_merge and gc_sweep_hp, we must + advance fl_merge to the new block, so that fl_merge is always the + last free-list block before gc_sweep_hp. */ + if (prev == fl_merge && bp <= gc_sweep_hp) fl_merge = bp; + } +} diff --git a/byterun/freelist.h b/byterun/freelist.h new file mode 100644 index 0000000000..1f1aef9a7f --- /dev/null +++ b/byterun/freelist.h @@ -0,0 +1,16 @@ +/* Free lists of heap blocks. */ + +#ifndef _freelist_ +#define _freelist_ + + +#include "misc.h" +#include "mlvalues.h" + +char *fl_allocate P((mlsize_t)); +void fl_init_merge P((void)); +char *fl_merge_block P((char *)); +void fl_add_block P((char *)); + + +#endif /* _freelist_ */ diff --git a/byterun/gc.h b/byterun/gc.h new file mode 100644 index 0000000000..b772f2f28d --- /dev/null +++ b/byterun/gc.h @@ -0,0 +1,42 @@ +#ifndef _gc_ +#define _gc_ + + +#include "mlvalues.h" + +/* Defined in [major_gc.c]. */ +extern unsigned free_mem_percent_min, free_mem_percent_max; + +#define White (0 << 8) +#define Gray (1 << 8) +#define Blue (2 << 8) +#define Black (3 << 8) + +#define Color_hd(hd) ((color_t) ((hd) & Black)) +#define Color_hp(hp) Color_hd (Hd_hp (hp)) + +#define Is_white_hd(hd) (Color_hd (hd) == White) +#define Is_gray_hd(hd) (Color_hd (hd) == Gray) +#define Is_blue_hd(hd) (Color_hd (hd) == Blue) +#define Is_black_hd(hd) (Color_hd (hd) == Black) + +#define Whitehd_hd(hd) ((hd) & ~Black) +#define Grayhd_hd(hd) (((hd) & ~Black) | Gray) +#define Blackhd_hd(hd) ((hd) | Black) +#define Bluehd_hd(hd) (((hd) & ~Black) | Blue) + +/* This depends on the layout of the header. See [mlvalues.h]. */ +#define Make_header(wosize, tag, color) \ + ((header_t) (((header_t) (wosize) << 10) \ + + (color) \ + + (tag_t) (tag))) + +#define Color_val(val) (Color_hd (Hd_val (val))) + +#define Is_white_val(val) (Color_val(val) == White) +#define Is_gray_val(val) (Color_val(val) == Gray) +#define Is_blue_val(val) (Color_val(val) == Blue) +#define Is_black_val(val) (Color_val(val) == Black) + + +#endif /* _gc_ */ diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c new file mode 100644 index 0000000000..facd9f30f7 --- /dev/null +++ b/byterun/gc_ctrl.c @@ -0,0 +1,212 @@ +#include "alloc.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" + +long stat_minor_words = 0, + stat_promoted_words = 0, + stat_major_words = 0, + stat_minor_collections = 0, + stat_major_collections = 0, + stat_heap_size = 0; /* bytes */ + +extern asize_t major_heap_increment; /* bytes; cf. major_gc.c */ +extern int percent_free; /* cf. major_gc.c */ +extern int verb_gc; /* cf. misc.c */ + +#define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size +#define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next +#define Next(hp) ((hp) + Bhsize_hp (hp)) + +/* This will also thoroughly verify the heap if compiled in DEBUG mode. */ + +value gc_stat(v) /* ML */ + value v; +{ + value res; + long live_words = 0, live_blocks = 0, + free_words = 0, free_blocks = 0, largest_free = 0, + fragments = 0, heap_chunks = 0; + char *chunk = heap_start, *chunk_end; + char *cur_hp, *prev_hp; + header_t cur_hd; + + Assert (v == Atom (0)); + + while (chunk != NULL){ + ++ heap_chunks; + chunk_end = chunk + Chunk_size (chunk); + prev_hp = NULL; + cur_hp = chunk; + while (cur_hp < chunk_end){ + cur_hd = Hd_hp (cur_hp); + switch (Color_hd (cur_hd)){ + case White: + if (Wosize_hd (cur_hd) == 0){ + ++fragments; + Assert (prev_hp == NULL + || (Color_hp (prev_hp) != Blue + && Wosize_hp (prev_hp) > 0)); + Assert (Next (cur_hp) == chunk_end + || (Color_hp (Next (cur_hp)) != Blue + && Wosize_hp (Next (cur_hp)) > 0)); + break; + } + /* FALLTHROUGH */ + case Gray: case Black: + Assert (Wosize_hd (cur_hd) > 0); + ++ live_blocks; + live_words += Whsize_hd (cur_hd); + break; + case Blue: + Assert (Wosize_hd (cur_hd) > 0); + ++ free_blocks; + free_words += Whsize_hd (cur_hd); + if (Whsize_hd (cur_hd) > largest_free){ + largest_free = Whsize_hd (cur_hd); + } + Assert (prev_hp == NULL + || (Color_hp (prev_hp) != Blue + && Wosize_hp (prev_hp) > 0)); + Assert (Next (cur_hp) == chunk_end + || (Color_hp (Next (cur_hp)) != Blue + && Wosize_hp (Next (cur_hp)) > 0)); + break; + } + prev_hp = cur_hp; + cur_hp = Next (cur_hp); + } Assert (cur_hp == chunk_end); + chunk = Chunk_next (chunk); + } + + Assert (live_words + free_words + fragments == Wsize_bsize (stat_heap_size)); + + res = alloc (13, 0); + Field (res, 0) = Val_long (stat_minor_words + + Wsize_bsize (young_ptr - young_start)); + Field (res, 1) = Val_long (stat_promoted_words); + Field (res, 2) = Val_long (stat_major_words + allocated_words); + Field (res, 3) = Val_long (stat_minor_collections); + Field (res, 4) = Val_long (stat_major_collections); + Field (res, 5) = Val_long (Wsize_bsize (stat_heap_size)); + Field (res, 6) = Val_long (heap_chunks); + Field (res, 7) = Val_long (live_words); + Field (res, 8) = Val_long (live_blocks); + Field (res, 9) = Val_long (free_words); + Field (res, 10) = Val_long (free_blocks); + Field (res, 11) = Val_long (largest_free); + Field (res, 12) = Val_long (fragments); + return res; +} + +value gc_get(v) /* ML */ + value v; +{ + value res; + + Assert (v == Atom (0)); + res = alloc (4, 0); + Field (res, 0) = Wsize_bsize (Val_long (minor_heap_size)); + Field (res, 1) = Wsize_bsize (Val_long (major_heap_increment)); + Field (res, 2) = Val_long (percent_free); + Field (res, 3) = Val_bool (verb_gc); + return res; +} + +static int norm_pfree (p) + int p; +{ + if (p < 1) return p = 1; + return p; +} + +static long norm_heapincr (i) + long i; +{ + i = ((i + (1 << Page_log) - 1) >> Page_log) << Page_log; + if (i < Heap_chunk_min) i = Heap_chunk_min; + if (i > Heap_chunk_max) i = Heap_chunk_max; + return i; +} + +static long norm_minsize (s) + long s; +{ + if (s < Minor_heap_min) s = Minor_heap_min; + if (s > Minor_heap_max) s = Minor_heap_max; + return s; +} + +value gc_set(v) /* ML */ + value v; +{ + int newpf; + + verb_gc = Bool_val (Field (v, 3)); + + newpf = norm_pfree (Long_val (Field (v, 2))); + if (newpf != percent_free){ + percent_free = newpf; + gc_message ("New space overhead: %d%%\n", percent_free); + } + + if (Bsize_wsize (Long_val (Field (v, 1))) != major_heap_increment){ + major_heap_increment = norm_heapincr (Bsize_wsize (Long_val (Field(v,1)))); + gc_message ("New heap increment size: %ldk\n", major_heap_increment/1024); + } + + /* Minor heap size comes last because it will trigger a minor collection + (thus invalidating [v]) and it can raise [Out_of_memory]. */ + if (Bsize_wsize (Long_val (Field (v, 0))) != minor_heap_size){ + long new_size = norm_minsize (Bsize_wsize (Long_val (Field (v, 0)))); + gc_message ("New minor heap size: %ldk\n", new_size/1024); + set_minor_heap_size (new_size); + } + return Atom (0); +} + +value gc_minor(v) /* ML */ + value v; +{ Assert (v == Atom (0)); + minor_collection (); + return Atom (0); +} + +value gc_major(v) /* ML */ + value v; +{ Assert (v == Atom (0)); + minor_collection (); + finish_major_cycle (); + return Atom (0); +} + +value gc_full_major(v) /* ML */ + value v; +{ Assert (v == Atom (0)); + minor_collection (); + finish_major_cycle (); + finish_major_cycle (); + return Atom (0); +} + +void init_gc (minor_size, major_incr, percent_fr, verb) + long minor_size; + long major_incr; + int percent_fr; + int verb; +{ +#ifdef DEBUG + gc_message ("*** camlrun: debug mode ***\n", 0); +#endif + verb_gc = verb; + set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); + major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); + percent_free = norm_pfree (percent_fr); + init_major_heap (major_heap_increment); + gc_message ("Initial space overhead: %d%%\n", percent_free); + gc_message ("Initial heap increment: %ldk\n", major_heap_increment / 1024); + gc_message ("Initial minor heap size: %ldk\n", minor_heap_size / 1024); +} diff --git a/byterun/gc_ctrl.h b/byterun/gc_ctrl.h new file mode 100644 index 0000000000..5a88a9ab61 --- /dev/null +++ b/byterun/gc_ctrl.h @@ -0,0 +1,17 @@ +#ifndef _gc_ctrl_ +#define _gc_ctrl_ + +#include "misc.h" + +extern long + stat_minor_words, + stat_promoted_words, + stat_major_words, + stat_minor_collections, + stat_major_collections, + stat_heap_size; + +void init_gc P((long, long, int, int)); + + +#endif /* _gc_ctrl_ */ diff --git a/byterun/hash.c b/byterun/hash.c new file mode 100644 index 0000000000..944bfac985 --- /dev/null +++ b/byterun/hash.c @@ -0,0 +1,103 @@ +/* The generic hashing primitive */ + +#include "mlvalues.h" +#include "memory.h" +#include "str.h" + +static unsigned long hash_accu; +static long hash_univ_limit, hash_univ_count; + +static void hash_aux(); + +value hash_univ_param(count, limit, obj) /* ML */ + value obj, count, limit; +{ + hash_univ_limit = Long_val(limit); + hash_univ_count = Long_val(count); + hash_accu = 0; + hash_aux(obj); + return Val_long(hash_accu & 0x3FFFFFFF); + /* The & has two purposes: ensure that the return value is positive + and give the same result on 32 bit and 64 bit architectures. */ +} + +#define Alpha 65599 +#define Beta 19 +#define Combine(new) (hash_accu = hash_accu * Alpha + (new)) +#define Combine_small(new) (hash_accu = hash_accu * Beta + (new)) + +static void hash_aux(obj) + value obj; +{ + unsigned char * p; + mlsize_t i; + tag_t tag; + + hash_univ_limit--; + if (hash_univ_count < 0 || hash_univ_limit < 0) return; + + if (Is_long(obj)) { + hash_univ_count--; + Combine(Long_val(obj)); + return; + } + + /* Atoms are not in the heap, but it's better to hash their tag + than to do nothing. */ + + if (Is_atom(obj)) { + tag = Tag_val(obj); + hash_univ_count--; + Combine_small(tag); + return; + } + + /* Pointers into the heap are well-structured blocks. + We can inspect the block contents. */ + + if (Is_in_heap(obj) || Is_young(obj)) { + tag = Tag_val(obj); + switch (tag) { + case String_tag: + hash_univ_count--; + i = string_length(obj); + for (p = &Byte_u(obj, 0); i > 0; i--, p++) + Combine_small(*p); + break; + case Double_tag: + /* For doubles, we inspect their binary representation, LSB first. + The results are consistent among all platforms with IEEE floats. */ + hash_univ_count--; +#ifdef BIG_ENDIAN + for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double); + i > 0; + p--, i--) +#else + for (p = &Byte_u(obj, 0), i = sizeof(double); + i > 0; + p++, i--) +#endif + Combine_small(*p); + break; + case Abstract_tag: + case Final_tag: + /* We don't know anything about the contents of the block. + Better do nothing. */ + break; + default: + hash_univ_count--; + Combine_small(tag); + i = Wosize_val(obj); + while (i != 0) { + i--; + hash_aux(Field(obj, i)); + } + break; + } + return; + } + + /* Otherwise, obj is a pointer outside the heap, to an object with + a priori unknown structure. Use its physical address as hash key. */ + Combine((long) obj); +} diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c new file mode 100644 index 0000000000..5e3133565f --- /dev/null +++ b/byterun/instrtrace.c @@ -0,0 +1,52 @@ +/* Trace the instructions executed */ + +#ifdef DEBUG + +#include <stdio.h> +#include "instruct.h" +#include "misc.h" +#include "mlvalues.h" +#include "opnames.h" + +extern code_t start_code; +extern char * names_of_cprim[]; + +long icount = 0; + +void stop_here () {} + +int trace_flag = 0; + +void disasm_instr(pc) + code_t pc; +{ + int instr = *pc; + printf("%6d %s", pc - start_code, + instr < 0 || instr > STOP ? "???" : names_of_instructions[instr]); + pc++; + switch(instr) { + /* Instructions with one integer operand */ + case PUSHACC: case ACC: case POP: case ASSIGN: + case PUSHENVACC: case ENVACC: case PUSH_RETADDR: case APPLY: + case APPTERM1: case APPTERM2: case APPTERM3: case RETURN: + case GRAB: case PUSHGETGLOBAL: case GETGLOBAL: case SETGLOBAL: + case PUSHATOM: case ATOM: case MAKEBLOCK1: case MAKEBLOCK2: + case MAKEBLOCK3: case GETFIELD: case SETFIELD: case DUMMY: + case BRANCH: case BRANCHIF: case BRANCHIFNOT: case PUSHTRAP: + case CONSTINT: case PUSHCONSTINT: case OFFSETINT: case OFFSETREF: + printf(" %d\n", pc[0]); break; + /* Instructions with two operands */ + case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD: + case GETGLOBALFIELD: case MAKEBLOCK: + printf(" %d, %d\n", pc[0], pc[1]); break; + /* Instructions with a C primitive as operand */ + case C_CALL1: case C_CALL2: case C_CALL3: case C_CALL4: + printf(" %s\n", names_of_cprim[pc[0]]); break; + case C_CALLN: + printf(" %d, %s\n", pc[0], names_of_cprim[pc[1]]); break; + default: + printf("\n"); + } +} + +#endif diff --git a/byterun/instrtrace.h b/byterun/instrtrace.h new file mode 100644 index 0000000000..c47b39781c --- /dev/null +++ b/byterun/instrtrace.h @@ -0,0 +1,16 @@ +/* Trace the instructions executed */ + +#ifndef _instrtrace_ +#define _instrtrace_ + + +#include "mlvalues.h" +#include "misc.h" + +extern int trace_flag; +extern long icount; +void stop_here P((void)); +void disasm_instr P((code_t pc)); + + +#endif diff --git a/byterun/instruct.h b/byterun/instruct.h new file mode 100644 index 0000000000..43cb8dcdf0 --- /dev/null +++ b/byterun/instruct.h @@ -0,0 +1,33 @@ +/* The instruction set. */ + +enum instructions { + ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, + ACC, PUSH, + PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, + PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7, + PUSHACC, POP, ASSIGN, + ENVACC0, ENVACC1, ENVACC2, ENVACC3, ENVACC, + PUSHENVACC0, PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC, + PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3, + APPTERM, APPTERM1, APPTERM2, APPTERM3, + RETURN, RESTART, GRAB, + CLOSURE, CLOSUREREC, + GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL, + ATOM0, ATOM1, ATOM2, ATOM3, ATOM, + PUSHATOM0, PUSHATOM1, PUSHATOM2, PUSHATOM3, PUSHATOM, + MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, + GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, + SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, + TAGOF, DUMMY, UPDATE, + VECTLENGTH, GETVECTITEM, SETVECTITEM, + GETSTRINGCHAR, SETSTRINGCHAR, + BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, TRANSLATE, BOOLNOT, + PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS, + C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALLN, + CONSTINT, PUSHCONSTINT, + NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT, + ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT, + EQ, NEQ, LTINT, LEINT, GTINT, GEINT, + OFFSETINT, OFFSETREF, + STOP +}; diff --git a/byterun/intern.c b/byterun/intern.c new file mode 100644 index 0000000000..4fb438b44a --- /dev/null +++ b/byterun/intern.c @@ -0,0 +1,230 @@ +/* Structured input, compact format */ + +#include "fail.h" +#include "gc.h" +#include "intext.h" +#include "io.h" +#include "memory.h" +#include "mlvalues.h" +#include "misc.h" +#include "reverse.h" + +static header_t * intern_ptr; +static asize_t obj_counter; +static value * intern_obj_table; +static unsigned int intern_color; +static header_t intern_header; +static value intern_block; + +#define Sign_extend_shift ((sizeof(long) - 1) * 8) +#define Sign_extend(x) (((long)(x) << Sign_extend_shift) >> Sign_extend_shift) + +static long input8u(chan) + struct channel * chan; +{ + return getch(chan); +} + +static long input8s(chan) + struct channel * chan; +{ + long b1 = getch(chan); + return Sign_extend(b1); +} + +static long input16u(chan) + struct channel * chan; +{ + long b1 = getch(chan); + long b2 = getch(chan); + return (b1 << 8) + b2; +} + +static long input16s(chan) + struct channel * chan; +{ + long b1 = getch(chan); + long b2 = getch(chan); + return (Sign_extend(b1) << 8) + b2; +} + +static long input32u(chan) + struct channel * chan; +{ + long b1 = getch(chan); + long b2 = getch(chan); + long b3 = getch(chan); + long b4 = getch(chan); + return (b1 << 24) + (b2 << 16) + (b3 << 8) + b4; +} + +static long input32s(chan) + struct channel * chan; +{ + long b1 = getch(chan); + long b2 = getch(chan); + long b3 = getch(chan); + long b4 = getch(chan); + return (Sign_extend(b1) << 24) + (b2 << 16) + (b3 << 8) + b4; +} + +#ifdef SIXTYFOUR +static long input64s(chan) + struct channel * chan; +{ + long res; + int i; + res = 0; + for (i = 0; i < 8; i++) res = (res << 8) + getch(chan); + return res; +} +#endif + +static void read_compact(chan, dest) + struct channel * chan; + value * dest; +{ + unsigned int code; + tag_t tag; + mlsize_t size, len, ofs_ind; + value v; + asize_t ofs; + header_t header; + + tailcall: + code = getch(chan); + if (code >= PREFIX_SMALL_INT) { + if (code >= PREFIX_SMALL_BLOCK) { + /* Small block */ + tag = code & 0xF; + size = (code >> 4) & 0x7; + read_block: + if (size == 0) { + v = Atom(tag); + } else { + v = Val_hp(intern_ptr); + *dest = v; + intern_obj_table[obj_counter++] = v; + dest = (value *) (intern_ptr + 1); + *intern_ptr = Make_header(size, tag, intern_color); + intern_ptr += 1 + size; + for(/*nothing*/; size > 1; size--, dest++) + read_compact(chan, dest); + goto tailcall; + } + } else { + /* Small integer */ + v = Val_int(code & 0x3F); + } + } else { + if (code >= PREFIX_SMALL_STRING) { + /* Small string */ + len = (code & 0x1F); + read_string: + size = (len + sizeof(value)) / sizeof(value); + v = Val_hp(intern_ptr); + intern_obj_table[obj_counter++] = v; + *intern_ptr = Make_header(size, String_tag, intern_color); + intern_ptr += 1 + size; + Field(v, size - 1) = 0; + ofs_ind = Bsize_wsize(size) - 1; + Byte(v, ofs_ind) = ofs_ind - len; + really_getblock(chan, String_val(v), len); + } else { + switch(code) { + case CODE_INT8: + v = Val_long(input8s(chan)); + break; + case CODE_INT16: + v = Val_long(input16s(chan)); + break; + case CODE_INT32: + v = Val_long(input32s(chan)); + break; + case CODE_INT64: +#ifdef SIXTYFOUR + v = Val_long(input64s(chan)); + break; +#else + stat_free((char *) intern_obj_table); + Hd_val(intern_block) = intern_header; /* Don't confuse the GC */ + failwith("input_value: integer too large"); + break; +#endif + case CODE_SHARED8: + ofs = input8u(chan); + read_shared: + Assert(ofs > 0 && ofs <= obj_counter); + v = intern_obj_table[obj_counter - ofs]; + break; + case CODE_SHARED16: + ofs = input16u(chan); + goto read_shared; + case CODE_SHARED32: + ofs = input32u(chan); + goto read_shared; + case CODE_BLOCK32: + header = (header_t) input32u(chan); + tag = Tag_hd(header); + size = Wosize_hd(header); + goto read_block; + case CODE_STRING8: + len = input8u(chan); + goto read_string; + case CODE_STRING32: + len = input32u(chan); + goto read_string; + case CODE_DOUBLE_LITTLE: + case CODE_DOUBLE_BIG: + if (sizeof(double) != 8) { + stat_free((char *) intern_obj_table); + Hd_val(intern_block) = intern_header; /* Don't confuse the GC */ + invalid_argument("input_value: non-standard floats"); + } + v = Val_hp(intern_ptr); + intern_obj_table[obj_counter++] = v; + *intern_ptr = Make_header(Double_wosize, Double_tag, intern_color); + intern_ptr += 1 + Double_wosize; + really_getblock(chan, (char *) v, 8); + if (code != CODE_DOUBLE_NATIVE) Reverse_double(v); + break; + } + } + } + *dest = v; +} + +value input_value(chan) /* ML */ + struct channel * chan; +{ + uint32 magic; + mlsize_t num_objects, size_32, size_64, whsize; + value res; + + magic = getword(chan); + if (magic != Compact_magic_number) failwith("input_value: bad object"); + num_objects = getword(chan); + size_32 = getword(chan); + size_64 = getword(chan); +#ifdef SIXTYFOUR + whsize = size_64; +#else + whsize = size_32; +#endif + if (whsize == 0) { + read_compact(chan, &res); + } else { + if (Wosize_whsize(whsize) > Max_wosize) + failwith("intern: structure too big"); + intern_block = alloc_shr(Wosize_whsize(whsize), String_tag); + intern_header = Hd_val(intern_block); + intern_color = Color_hd(intern_header); + Assert (intern_color == White || intern_color == Black); + intern_ptr = (header_t *) Hp_val(intern_block); + obj_counter = 0; + intern_obj_table = (value *) stat_alloc(num_objects * sizeof(value)); + read_compact(chan, &res); + stat_free((char *) intern_obj_table); + } + return res; +} diff --git a/byterun/interp.c b/byterun/interp.c new file mode 100644 index 0000000000..2a5babc5a7 --- /dev/null +++ b/byterun/interp.c @@ -0,0 +1,865 @@ +/* The bytecode interpreter */ + +#include "alloc.h" +#include "fail.h" +#include "fix_code.h" +#include "instruct.h" +#include "interp.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "prims.h" +#include "signals.h" +#include "stacks.h" +#include "str.h" +#include "instrtrace.h" + +/* Registers for the abstract machine: + pc the code pointer + sp the stack pointer (grows downward) + accu the accumulator + env heap-allocated environment + trapsp pointer to the current trap frame + extra_args number of extra arguments provided by the caller + +sp is a local copy of the global variable extern_sp. */ + +extern value global_data; +extern code_t start_code; + +/* Instruction decoding */ + +#ifdef THREADED_CODE +# define Instruct(name) lbl_##name +# ifdef DEBUG +# define Next goto next_instr +# else +# define Next goto *((void *)((unsigned long)(*pc++))) +# endif +#else +# define Instruct(name) case name +# define Next break +#endif + +/* GC interface */ + +#define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = env; extern_sp = sp; } +#define Restore_after_gc { accu = sp[0]; env = sp[1]; sp += 2; } +#define Setup_for_c_call { *--sp = env; extern_sp = sp; } +#define Restore_after_c_call { sp = extern_sp; env = *sp++; } + +/* Register optimization. + Many compilers underestimate the use of the local variables representing + the abstract machine registers, and don't put them in hardware registers, + which slows down the interpreter considerably. + For GCC, I have hand-assigned hardware registers for several architectures. +*/ + +#if defined(__GNUC__) && !defined(DEBUG) +#ifdef __mips__ +#define PC_REG asm("$16") +#define SP_REG asm("$17") +#define ACCU_REG asm("$18") +#endif +#ifdef __sparc__ +#define PC_REG asm("%l0") +#define SP_REG asm("%l1") +#define ACCU_REG asm("%l2") +#endif +#ifdef __alpha__ +#define PC_REG asm("$9") +#define SP_REG asm("$10") +#define ACCU_REG asm("$11") +#endif +#ifdef __i386__ +#define PC_REG asm("%esi") +#define SP_REG asm("%edi") +#define ACCU_REG +#endif +#endif + +/* The interpreter itself */ + +value interprete(prog, prog_size) + code_t prog; + asize_t prog_size; +{ +#ifdef PC_REG + register code_t pc PC_REG; + register value * sp SP_REG; + register value accu ACCU_REG; +#else + register code_t pc; + register value * sp; + register value accu; +#endif + value env; + long extra_args; + struct longjmp_buffer * initial_external_raise; + int initial_sp_offset; + value * initial_local_roots; + struct longjmp_buffer raise_buf; + value * modify_dest, modify_newval; + +#ifdef THREADED_CODE + static void * jumptable[] = { +# include "jumptbl.h" + }; +#endif + +#ifdef THREADED_CODE + if (prog[0] <= STOP) thread_code(prog, prog_size, jumptable); +#endif + + sp = extern_sp; + pc = prog; + extra_args = 0; + env = Atom(0); + accu = Val_long(0); + initial_local_roots = local_roots; + initial_sp_offset = stack_high - sp; + initial_external_raise = external_raise; + if (setjmp(raise_buf.buf)) { + local_roots = initial_local_roots; + accu = exn_bucket; + goto raise_exception; + } + external_raise = &raise_buf; + +#ifdef THREADED_CODE +#ifdef DEBUG + next_instr: + if (icount-- == 0) stop_here (); + Assert(sp >= stack_low); + Assert(sp <= stack_high); + goto *((void *)((unsigned long)(*pc++))); +#else + Next; /* Jump to the first instruction */ +#endif +#else + while(1) { +#ifdef DEBUG + if (icount-- == 0) stop_here (); + if (trace_flag) disasm_instr(pc); + Assert(sp >= stack_low); + Assert(sp <= stack_high); +#endif + switch(*pc++) { +#endif + +/* Basic stack operations */ + + Instruct(ACC0): + accu = sp[0]; Next; + Instruct(ACC1): + accu = sp[1]; Next; + Instruct(ACC2): + accu = sp[2]; Next; + Instruct(ACC3): + accu = sp[3]; Next; + Instruct(ACC4): + accu = sp[4]; Next; + Instruct(ACC5): + accu = sp[5]; Next; + Instruct(ACC6): + accu = sp[6]; Next; + Instruct(ACC7): + accu = sp[7]; Next; + + Instruct(PUSH): Instruct(PUSHACC0): + *--sp = accu; Next; + Instruct(PUSHACC1): + *--sp = accu; accu = sp[1]; Next; + Instruct(PUSHACC2): + *--sp = accu; accu = sp[2]; Next; + Instruct(PUSHACC3): + *--sp = accu; accu = sp[3]; Next; + Instruct(PUSHACC4): + *--sp = accu; accu = sp[4]; Next; + Instruct(PUSHACC5): + *--sp = accu; accu = sp[5]; Next; + Instruct(PUSHACC6): + *--sp = accu; accu = sp[6]; Next; + Instruct(PUSHACC7): + *--sp = accu; accu = sp[7]; Next; + + Instruct(PUSHACC): + *--sp = accu; + /* Fallthrough */ + Instruct(ACC): + accu = sp[*pc++]; + Next; + + Instruct(POP): + sp += *pc++; + Next; + Instruct(ASSIGN): + sp[*pc++] = accu; + Next; + +/* Access in heap-allocated environment */ + + Instruct(ENVACC0): + accu = Field(env, 0); Next; + Instruct(ENVACC1): + accu = Field(env, 1); Next; + Instruct(ENVACC2): + accu = Field(env, 2); Next; + Instruct(ENVACC3): + accu = Field(env, 3); Next; + + Instruct(PUSHENVACC0): + *--sp = accu; accu = Field(env, 0); Next; + Instruct(PUSHENVACC1): + *--sp = accu; accu = Field(env, 1); Next; + Instruct(PUSHENVACC2): + *--sp = accu; accu = Field(env, 2); Next; + Instruct(PUSHENVACC3): + *--sp = accu; accu = Field(env, 3); Next; + + Instruct(PUSHENVACC): + *--sp = accu; + /* Fallthrough */ + Instruct(ENVACC): + accu = Field(env, *pc++); + Next; + +/* Function application */ + + Instruct(PUSH_RETADDR): { + sp -= 3; + sp[0] = (value) (pc + *pc); + sp[1] = env; + sp[2] = Val_long(extra_args); + pc++; + Next; + } + Instruct(APPLY): { + extra_args = *pc++ - 1; + pc = Code_val(accu); + env = Env_val(accu); + goto check_stacks; + } + Instruct(APPLY1): { + value arg1 = sp[0]; + sp -= 3; + sp[0] = arg1; + sp[1] = (value)pc; + sp[2] = env; + sp[3] = Val_long(extra_args); + pc = Code_val(accu); + env = Env_val(accu); + extra_args = 0; + goto check_stacks; + } + Instruct(APPLY2): { + value arg1 = sp[0]; + value arg2 = sp[1]; + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = (value)pc; + sp[3] = env; + sp[4] = Val_long(extra_args); + pc = Code_val(accu); + env = Env_val(accu); + extra_args = 1; + goto check_stacks; + } + Instruct(APPLY3): { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + sp[3] = (value)pc; + sp[4] = env; + sp[5] = Val_long(extra_args); + pc = Code_val(accu); + env = Env_val(accu); + extra_args = 2; + goto check_stacks; + } + + Instruct(APPTERM): { + int nargs = *pc++; + int slotsize = *pc++; + value * newsp; + int i; + /* Slide the nargs bottom words of the current frame to the top + of the frame, and discard the remainder of the frame */ + newsp = sp + slotsize - nargs; + for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i]; + sp = newsp; + pc = Code_val(accu); + env = Env_val(accu); + extra_args += nargs - 1; + goto check_stacks; + } + Instruct(APPTERM1): { + value arg1 = sp[0]; + sp = sp + *pc++ - 1; + sp[0] = arg1; + pc = Code_val(accu); + env = Env_val(accu); + goto check_stacks; + } + Instruct(APPTERM2): { + value arg1 = sp[0]; + value arg2 = sp[1]; + sp = sp + *pc++ - 2; + sp[0] = arg1; + sp[1] = arg2; + pc = Code_val(accu); + env = Env_val(accu); + extra_args += 1; + goto check_stacks; + } + Instruct(APPTERM3): { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + sp = sp + *pc++ - 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + pc = Code_val(accu); + env = Env_val(accu); + extra_args += 2; + goto check_stacks; + } + + Instruct(RETURN): { + sp += *pc++; + if (extra_args > 0) { + extra_args--; + pc = Code_val(accu); + env = Env_val(accu); + } else { + pc = (code_t)(sp[0]); + env = sp[1]; + extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + + Instruct(RESTART): { + int num_args = Wosize_val(env) - 1; + int i; + sp -= num_args; + for (i = 0; i < num_args; i++) sp[i] = Field(env, i); + env = Field(env, num_args); + extra_args += num_args; + Next; + } + + Instruct(GRAB): { + int required = *pc++; + if (extra_args >= required) { + extra_args -= required; + } else { + value clos; + mlsize_t num_args, i; + num_args = 1 + extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 1, 0); + for (i = 0; i < num_args; i++) Field(accu, i) = sp[i]; + Field(accu, num_args) = env; + sp += num_args; + Alloc_small(clos, Closure_wosize, Closure_tag); + Code_val(clos) = pc - 3; /* Point to the preceding RESTART instr. */ + Env_val(clos) = accu; + pc = (code_t)(sp[0]); + env = sp[1]; + extra_args = Long_val(sp[2]); + sp += 3; + accu = clos; + } + Next; + } + + Instruct(CLOSURE): { + int nvars = *pc++; + value clos; + int i; + if (nvars == 0) { + accu = Val_int(0); + } else { + *--sp = accu; + Alloc_small(accu, nvars, 0); + for (i = 0; i < nvars; i++) Field(accu, i) = sp[i]; + sp += nvars; + } + Alloc_small(clos, Closure_wosize, Closure_tag); + Code_val(clos) = pc + *pc; + Env_val(clos) = accu; + accu = clos; + pc++; + Next; + } + + Instruct(CLOSUREREC): { + int nvars = *pc++; + value fun_clos, fun_env; + int i; + Alloc_small(fun_env, nvars + 1, 0); + Field(fun_env, 0) = Val_int(0); + if (nvars > 0) { + *--sp = accu; + for (i = 0; i < nvars; i++) Field(fun_env, i+1) = sp[i]; + sp += nvars; + } + accu = fun_env; + Alloc_small(fun_clos, Closure_wosize, Closure_tag); + Code_val(fun_clos) = pc + *pc; + Env_val(fun_clos) = accu; + modify(&Field(accu, 0), fun_clos); + accu = fun_clos; + pc++; + Next; + } + + Instruct(PUSHGETGLOBAL): + *--sp = accu; + /* Fallthrough */ + Instruct(GETGLOBAL): + accu = Field(global_data, *pc); + pc++; + Next; + + Instruct(PUSHGETGLOBALFIELD): + *--sp = accu; + /* Fallthrough */ + Instruct(GETGLOBALFIELD): { + accu = Field(global_data, *pc); + pc++; + accu = Field(accu, *pc); + pc++; + Next; + } + + Instruct(SETGLOBAL): + modify(&Field(global_data, *pc), accu); + accu = Val_unit; + pc++; + Next; + +/* Allocation of blocks */ + + Instruct(ATOM0): + accu = Atom(0); Next; + Instruct(ATOM1): + accu = Atom(1); Next; + Instruct(ATOM2): + accu = Atom(2); Next; + Instruct(ATOM3): + accu = Atom(3); Next; + + Instruct(PUSHATOM0): + *--sp = accu; accu = Atom(0); Next; + Instruct(PUSHATOM1): + *--sp = accu; accu = Atom(1); Next; + Instruct(PUSHATOM2): + *--sp = accu; accu = Atom(2); Next; + Instruct(PUSHATOM3): + *--sp = accu; accu = Atom(3); Next; + + Instruct(PUSHATOM): + *--sp = accu; + /* Fallthrough */ + Instruct(ATOM): + accu = Atom(*pc); + pc++; + Next; + + Instruct(MAKEBLOCK): { + mlsize_t wosize = *pc++; + tag_t tag = *pc++; + mlsize_t i; + value block; + Alloc_small(block, wosize, tag); + Field(block, 0) = accu; + for (i = 1; i < wosize; i++) Field(block, i) = *sp++; + accu = block; + Next; + } + Instruct(MAKEBLOCK1): { + tag_t tag = *pc++; + value block; + Alloc_small(block, 1, tag); + Field(block, 0) = accu; + accu = block; + Next; + } + Instruct(MAKEBLOCK2): { + tag_t tag = *pc++; + value block; + Alloc_small(block, 2, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + sp += 1; + accu = block; + Next; + } + Instruct(MAKEBLOCK3): { + tag_t tag = *pc++; + value block; + Alloc_small(block, 3, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + Field(block, 2) = sp[1]; + sp += 2; + accu = block; + Next; + } + +/* Access to components of blocks */ + + Instruct(GETFIELD0): + accu = Field(accu, 0); Next; + Instruct(GETFIELD1): + accu = Field(accu, 1); Next; + Instruct(GETFIELD2): + accu = Field(accu, 2); Next; + Instruct(GETFIELD3): + accu = Field(accu, 3); Next; + Instruct(GETFIELD): + accu = Field(accu, *pc); pc++; Next; + + Instruct(SETFIELD0): + modify_dest = &Field(accu, 0); + modify_newval = *sp++; + modify: + Modify(modify_dest, modify_newval); + accu = Val_unit; + Next; + Instruct(SETFIELD1): + modify_dest = &Field(accu, 1); + modify_newval = *sp++; + goto modify; + Instruct(SETFIELD2): + modify_dest = &Field(accu, 2); + modify_newval = *sp++; + goto modify; + Instruct(SETFIELD3): + modify_dest = &Field(accu, 3); + modify_newval = *sp++; + goto modify; + Instruct(SETFIELD): + modify_dest = &Field(accu, *pc); + pc++; + modify_newval = *sp++; + goto modify; + + Instruct(TAGOF): + accu = Val_int(Tag_val(accu)); + Next; + +/* For recursive definitions */ + + Instruct(DUMMY): { + int size = *pc++; + Alloc_small(accu, size, 0); + while (size--) Field(accu, size) = Val_long(0); + Next; + } + Instruct(UPDATE): { + value newval = *sp++; + mlsize_t size, n; + Tag_val(accu) = Tag_val(newval); + size = Wosize_val(newval); + for (n = 0; n < size; n++) { + modify(&Field(accu, n), Field(newval, n)); + } + accu = Val_unit; + Next; + } + +/* Array operations */ + + Instruct(VECTLENGTH): + accu = Val_long(Wosize_val(accu)); + Next; + Instruct(GETVECTITEM): + accu = Field(accu, Long_val(sp[0])); + sp += 1; + Next; + Instruct(SETVECTITEM): + modify_dest = &Field(accu, Long_val(sp[0])); + modify_newval = sp[1]; + sp += 2; + goto modify; + +/* String operations */ + + Instruct(GETSTRINGCHAR): + accu = Val_int(Byte_u(accu, Long_val(sp[0]))); + sp += 1; + Next; + Instruct(SETSTRINGCHAR): + Byte_u(accu, Long_val(sp[0])) = Int_val(sp[1]); + sp += 2; + Next; + +/* Branches and conditional branches */ + + Instruct(BRANCH): + pc += *pc; + Next; + Instruct(BRANCHIF): + if (Tag_val(accu) != 0) pc += *pc; else pc++; + Next; + Instruct(BRANCHIFNOT): + if (Tag_val(accu) == 0) pc += *pc; else pc++; + Next; + Instruct(SWITCH): { + long index = Long_val(accu); + Assert(index >= 0 && index < *pc); + pc++; + pc += pc[index]; + Next; + } + Instruct(TRANSLATE): { + long arg = Long_val(accu); + int num_cases = *pc++; + int low, high, i; + uint32 interv; + for (low = 0, high = num_cases - 1, accu = Val_int(0); + low <= high; + /*nothing*/) { + i = (low + high) / 2; + interv = pc[i]; + if (arg < (interv & 0xFF)) + high = i - 1; + else if (arg > ((interv >> 8) & 0xFF)) + low = i + 1; + else { + accu = Val_long(arg + (interv >> 16) - (interv & 0xFF)); + break; + } + } + pc += num_cases; + Next; + } + Instruct(BOOLNOT): + accu = Atom(Tag_val(accu) == 0); + Next; + +/* Exceptions */ + + Instruct(PUSHTRAP): + sp -= 4; + Trap_pc(sp) = pc + *pc; + Trap_link(sp) = trapsp; + sp[2] = env; + sp[3] = Val_long(extra_args); + trapsp = sp; + pc++; + Next; + + Instruct(POPTRAP): + /* We should check here if a signal is pending, to preserve the + semantics of the program w.r.t. exceptions. Unfortunately, + process_signal destroys the accumulator, and there is no + convenient way to preserve it... */ + trapsp = Trap_link(sp); + sp += 4; + Next; + + Instruct(RAISE): /* arg */ + raise_exception: + sp = trapsp; + if (sp >= stack_high - initial_sp_offset) { + exn_bucket = accu; + external_raise = initial_external_raise; + longjmp(external_raise->buf, 1); + } + pc = Trap_pc(sp); + trapsp = Trap_link(sp); + env = sp[2]; + extra_args = Long_val(sp[3]); + sp += 4; + Next; + +/* Stack checks */ + + check_stacks: + if (sp < stack_threshold) { + extern_sp = sp; + realloc_stack(); + sp = extern_sp; + } + /* Fall through CHECK_SIGNALS */ + +/* Signal handling */ + + Instruct(CHECK_SIGNALS): /* accu not preserved */ + if (something_to_do) goto process_signal; + Next; + + process_signal: + something_to_do = 0; + if (force_minor_flag){ + force_minor_flag = 0; + Setup_for_gc; + minor_collection (); + Restore_after_gc; + } + /* If a signal arrives between the following two instructions, + it will be lost. */ + { int signal_number = pending_signal; + pending_signal = 0; + if (signal_number) { + /* Push a return frame to the current code location */ + sp -= 4; + sp[0] = (value) pc; + sp[1] = env; + sp[2] = Val_long(extra_args); + sp[3] = Val_int(signal_number); + pc = Code_val(Field(signal_handlers, signal_number)); + env = Env_val(Field(signal_handlers, signal_number)); + extra_args = 0; + } + } + Next; + +/* Calling C functions */ + + Instruct(C_CALL1): + Setup_for_c_call; + accu = cprim[*pc](accu); + Restore_after_c_call; + pc++; + Next; + Instruct(C_CALL2): + Setup_for_c_call; + accu = cprim[*pc](accu, sp[1]); + Restore_after_c_call; + sp += 1; + pc++; + Next; + Instruct(C_CALL3): + Setup_for_c_call; + accu = cprim[*pc](accu, sp[1], sp[2]); + Restore_after_c_call; + sp += 2; + pc++; + Next; + Instruct(C_CALL4): + Setup_for_c_call; + accu = cprim[*pc](accu, sp[1], sp[2], sp[3]); + Restore_after_c_call; + sp += 3; + pc++; + Next; + Instruct(C_CALLN): { + int nargs = *pc++; + *--sp = accu; + Setup_for_c_call; + accu = cprim[*pc](sp + 1, nargs); + Restore_after_c_call; + sp += nargs; + pc++; + Next; + } + +/* Integer arithmetic */ + + Instruct(CONSTINT): + accu = Val_int(*pc); + pc++; + Next; + Instruct(PUSHCONSTINT): + *--sp = accu; + accu = Val_int(*pc); + pc++; + Next; + Instruct(NEGINT): + accu = (value)(2 - (long)accu); Next; + Instruct(ADDINT): + accu = (value)((long) accu + (long) *sp++ - 1); Next; + Instruct(SUBINT): + accu = (value)((long) accu - (long) *sp++ + 1); Next; + Instruct(MULINT): + accu = Val_long(Long_val(accu) * Long_val(*sp++)); Next; + Instruct(DIVINT): { + value div = *sp++; + if (div == Val_long(0)) { + accu = Field(global_data, ZERO_DIVIDE_EXN); + goto raise_exception; + } + accu = Val_long(Long_val(accu) / Long_val(div)); + Next; + } + Instruct(MODINT): { + value div = *sp++; + if (div == Val_long(0)) { + accu = Field(global_data, ZERO_DIVIDE_EXN); + goto raise_exception; + } + accu = Val_long(Long_val(accu) % Long_val(div)); + Next; + } + Instruct(ANDINT): + accu = (value)((long) accu & (long) *sp++); Next; + Instruct(ORINT): + accu = (value)((long) accu | (long) *sp++); Next; + Instruct(XORINT): + accu = (value)(((long) accu ^ (long) *sp++) | 1); Next; + Instruct(LSLINT): + accu = (value)((((long) accu - 1) << Long_val(*sp++)) + 1); Next; + Instruct(LSRINT): + accu = (value)((((long) accu - 1) >> Long_val(*sp++)) | 1); Next; + Instruct(ASRINT): + accu = (value)((((unsigned long) accu - 1) >> Long_val(*sp++)) | 1); + Next; + +#define Integer_comparison(opname,tst) \ + Instruct(opname): \ + accu = Atom((long) accu tst (long) *sp++); Next; + + Integer_comparison(EQ, ==) + Integer_comparison(NEQ, !=) + Integer_comparison(LTINT, <) + Integer_comparison(LEINT, <=) + Integer_comparison(GTINT, >) + Integer_comparison(GEINT, >=) + + Instruct(OFFSETINT): + accu += *pc << 1; + pc++; + Next; + Instruct(OFFSETREF): + Field(accu, 0) += *pc << 1; + pc++; + Next; + +/* Machine control */ + + Instruct(STOP): + external_raise = initial_external_raise; + extern_sp = sp; + return accu; + +#ifndef THREADED_CODE + default: + fatal_error("bad opcode"); + } + } +#endif +} + +static opcode_t callback_code[] = { + ACC1, APPLY1, POP, 1, STOP +}; + +value callback(closure, argument) + value closure, argument; +{ + extern_sp -= 2; + extern_sp[0] = argument; + extern_sp[1] = closure; + return interprete(callback_code, sizeof(callback_code)); +} diff --git a/byterun/interp.h b/byterun/interp.h new file mode 100644 index 0000000000..e652331d8a --- /dev/null +++ b/byterun/interp.h @@ -0,0 +1,14 @@ +/* The bytecode interpreter */ + +#ifndef _interp_ +#define _interp_ + + +#include "misc.h" +#include "mlvalues.h" + +value interprete P((code_t prog, asize_t prog_size)); +value callback P((value closure, value argument)); + + +#endif _interp_ diff --git a/byterun/intext.h b/byterun/intext.h new file mode 100644 index 0000000000..7b1a26c414 --- /dev/null +++ b/byterun/intext.h @@ -0,0 +1,54 @@ +/* Structured input/output */ + +#ifndef __intext__ +#define __intext__ + +#include "misc.h" +#include "mlvalues.h" +#include "io.h" + +/* Magic number */ + +#define Base_magic_number 0x8495A6B9 +#define Compact_magic_number (Base_magic_number + 4) + +/* Codes for the compact format */ + +#define PREFIX_SMALL_BLOCK 0x80 +#define PREFIX_SMALL_INT 0x40 +#define PREFIX_SMALL_STRING 0x20 +#define CODE_INT8 0x0 +#define CODE_INT16 0x1 +#define CODE_INT32 0x2 +#define CODE_INT64 0x3 +#define CODE_SHARED8 0x4 +#define CODE_SHARED16 0x5 +#define CODE_SHARED32 0x6 +#define CODE_BLOCK32 0x8 +#define CODE_STRING8 0x9 +#define CODE_STRING32 0xA +#define CODE_DOUBLE_BIG 0xB +#define CODE_DOUBLE_LITTLE 0xC +#ifdef BIG_ENDIAN +#define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG +#else +#define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE +#endif + +/* Initial sizes of data structures for extern */ + +#ifndef INITIAL_EXTERN_SIZE +#define INITIAL_EXTERN_SIZE 4096 +#endif +#ifndef INITIAL_EXTERN_TABLE_SIZE +#define INITIAL_EXTERN_TABLE_SIZE 2039 +#endif + +/* The entry points */ + +value output_value P((struct channel *, value)); +value input_value P((struct channel *)); + + +#endif + diff --git a/byterun/ints.c b/byterun/ints.c new file mode 100644 index 0000000000..4a4f767225 --- /dev/null +++ b/byterun/ints.c @@ -0,0 +1,81 @@ +#include <stdio.h> +#include "alloc.h" +#include "fail.h" +#include "memory.h" +#include "mlvalues.h" + +value int_of_string(s) /* ML */ + value s; +{ + long res; + int sign; + int base; + char * p; + int c, d; + + p = String_val(s); + if (*p == 0) failwith("int_of_string"); + sign = 1; + if (*p == '-') { + sign = -1; + p++; + } + base = 10; + if (*p == '0') { + switch (p[1]) { + case 'x': case 'X': + base = 16; p += 2; break; + case 'o': case 'O': + base = 8; p += 2; break; + case 'b': case 'B': + base = 2; p += 2; break; + } + } + res = 0; + while (1) { + c = *p; + if (c >= '0' && c <= '9') + d = c - '0'; + else if (c >= 'A' && c <= 'F') + d = c - 'A' + 10; + else if (c >= 'a' && c <= 'f') + d = c - 'a' + 10; + else + break; + if (d >= base) break; + res = base * res + d; + p++; + } + if (*p != 0) + failwith("int_of_string"); + return Val_long(sign < 0 ? -res : res); +} + +value format_int(fmt, arg) /* ML */ + value fmt, arg; +{ + char format_buffer[32]; + int prec; + char * p; + char * dest; + value res; + + prec = 32; + for (p = String_val(fmt); *p != 0; p++) { + if (*p >= '0' && *p <= '9') { + prec = atoi(p) + 5; + break; + } + } + if (prec <= sizeof(format_buffer)) { + dest = format_buffer; + } else { + dest = stat_alloc(prec); + } + sprintf(dest, String_val(fmt), Long_val(arg)); + res = copy_string(dest); + if (dest != format_buffer) { + stat_free(dest); + } + return res; +} diff --git a/byterun/io.c b/byterun/io.c new file mode 100644 index 0000000000..67bc961f78 --- /dev/null +++ b/byterun/io.c @@ -0,0 +1,393 @@ +/* Buffered input/output. */ + +#include <errno.h> +#include <fcntl.h> +#include <string.h> +#include <unistd.h> +#include "alloc.h" +#include "fail.h" +#include "io.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "signals.h" +#include "sys.h" +#ifdef HAS_UI +#include "ui.h" +#endif + +/* Common functions. */ + +struct channel * open_descr(fd) + int fd; +{ + struct channel * channel; + + channel = (struct channel *) stat_alloc(sizeof(struct channel)); + channel->fd = fd; + channel->offset = 0; + channel->curr = channel->max = channel->buff; + channel->end = channel->buff + IO_BUFFER_SIZE; + return channel; +} + +value open_descriptor(fd) /* ML */ + value fd; +{ + return (value) open_descr(Int_val(fd)); +} + +value channel_descriptor(channel) /* ML */ + struct channel * channel; +{ + return Val_long(channel->fd); +} + +value channel_size(channel) /* ML */ + struct channel * channel; +{ + long end; + + end = lseek(channel->fd, 0, 2); + if (end == -1) sys_error(NULL); + if (lseek(channel->fd, channel->offset, 0) != channel->offset) + sys_error(NULL); + return Val_long(end); +} + +/* Output */ + +static void really_write(fd, p, n) + int fd; + char * p; + int n; +{ + int retcode; + while (n > 0) { +#ifdef HAS_UI + retcode = ui_write(fd, p, n); +#else +#ifdef EINTR + do { retcode = write(fd, p, n); } while (retcode == -1 && errno == EINTR); +#else + retcode = write(fd, p, n); +#endif +#endif + if (retcode == -1) sys_error(NULL); + p += retcode; + n -= retcode; + } +} + +value flush(channel) /* ML */ + struct channel * channel; +{ + int n; + n = channel->max - channel->buff; + if (n > 0) { + really_write(channel->fd, channel->buff, n); + channel->offset += n; + channel->curr = channel->buff; + channel->max = channel->buff; + } + return Atom(0); +} + +value output_char(channel, ch) /* ML */ + struct channel * channel; + value ch; +{ + putch(channel, Long_val(ch)); + return Atom(0); +} + +void putword(channel, w) + struct channel * channel; + uint32 w; +{ + putch(channel, w >> 24); + putch(channel, w >> 16); + putch(channel, w >> 8); + putch(channel, w); +} + +value output_int(channel, w) /* ML */ + struct channel * channel; + value w; +{ + putword(channel, Long_val(w)); + return Atom(0); +} + +void putblock(channel, p, n) + struct channel * channel; + char * p; + unsigned n; +{ + unsigned m; + + m = channel->end - channel->curr; + if (channel->curr == channel->buff && n >= m) { + really_write(channel->fd, p, n); + channel->offset += n; + } else if (n <= m) { + bcopy(p, channel->curr, n); + channel->curr += n; + if (channel->curr > channel->max) channel->max = channel->curr; + } else { + bcopy(p, channel->curr, m); + p += m; + n -= m; + m = channel->end - channel->buff; + really_write(channel->fd, channel->buff, m); + channel->offset += m; + if (n <= m) { + bcopy(p, channel->buff, n); + channel->curr = channel->max = channel->buff + n; + } else { + really_write(channel->fd, p, n); + channel->offset += n; + channel->curr = channel->max = channel->buff; + } + } +} + +value output(channel, buff, start, length) /* ML */ + value channel, buff, start, length; +{ + putblock((struct channel *) channel, + &Byte(buff, Long_val(start)), + (unsigned) Long_val(length)); + return Atom(0); +} + +value seek_out(channel, pos) /* ML */ + struct channel * channel; + value pos; +{ + long dest; + + dest = Long_val(pos); + if (dest >= channel->offset && + dest <= channel->offset + channel->max - channel->buff) { + channel->curr = channel->buff + dest - channel->offset; + } else { + flush(channel); + if (lseek(channel->fd, dest, 0) != dest) sys_error(NULL); + channel->offset = dest; + } + return Atom(0); +} + +value pos_out(channel) /* ML */ + struct channel * channel; +{ + return Val_long(channel->offset + channel->curr - channel->buff); +} + +value close_out(channel) /* ML */ + struct channel * channel; +{ + flush(channel); + close(channel->fd); + stat_free((char *) channel); + return Atom(0); +} + +/* Input */ + +static int really_read(fd, p, n) + int fd; + char * p; + unsigned n; +{ + int retcode; + + enter_blocking_section(); +#ifdef HAS_UI + retcode = ui_read(fd, p, n); +#else +#ifdef EINTR + do { retcode = read(fd, p, n); } while (retcode == -1 && errno == EINTR); +#else + retcode = read(fd, p, n); +#endif +#endif + leave_blocking_section(); + if (retcode == -1) sys_error(NULL); + return retcode; +} + +unsigned char refill(channel) + struct channel * channel; +{ + int n; + + n = really_read(channel->fd, channel->buff, IO_BUFFER_SIZE); + if (n == 0) raise_end_of_file(); + channel->offset += n; + channel->max = channel->buff + n; + channel->curr = channel->buff + 1; + return (unsigned char)(channel->buff[0]); +} + +value input_char(channel) /* ML */ + struct channel * channel; +{ + unsigned char c; + c = getch(channel); + return Val_long(c); +} + +uint32 getword(channel) + struct channel * channel; +{ + int i; + uint32 res; + + res = 0; + for(i = 0; i < 4; i++) { + res = (res << 8) + getch(channel); + } + return res; +} + +value input_int(channel) /* ML */ + struct channel * channel; +{ + long i; + i = getword(channel); +#ifdef SIXTYFOUR + i = (i << 32) >> 32; /* Force sign extension */ +#endif + return Val_long(i); +} + +unsigned getblock(channel, p, n) + struct channel * channel; + char * p; + unsigned n; +{ + unsigned m, l; + + m = channel->max - channel->curr; + if (n <= m) { + bcopy(channel->curr, p, n); + channel->curr += n; + return n; + } else if (m > 0) { + bcopy(channel->curr, p, m); + channel->curr += m; + return m; + } else if (n < IO_BUFFER_SIZE) { + l = really_read(channel->fd, channel->buff, IO_BUFFER_SIZE); + channel->offset += l; + channel->max = channel->buff + l; + if (n > l) n = l; + bcopy(channel->buff, p, n); + channel->curr = channel->buff + n; + return n; + } else { + channel->curr = channel->buff; + channel->max = channel->buff; + l = really_read(channel->fd, p, n); + channel->offset += l; + return l; + } +} + +int really_getblock(chan, p, n) + struct channel * chan; + char * p; + unsigned long n; +{ + unsigned r; + while (n > 0) { + r = getblock(chan, p, (unsigned) n); + if (r == 0) return 0; + p += r; + n -= r; + } + return 1; +} + +value input(channel, buff, start, length) /* ML */ + value channel, buff, start, length; +{ + return Val_long(getblock((struct channel *) channel, + &Byte(buff, Long_val(start)), + (unsigned) Long_val(length))); +} + +value seek_in(channel, pos) /* ML */ + struct channel * channel; + value pos; +{ + long dest; + + dest = Long_val(pos); + if (dest >= channel->offset - (channel->max - channel->buff) && + dest <= channel->offset) { + channel->curr = channel->max - (channel->offset - dest); + } else { + if (lseek(channel->fd, dest, 0) != dest) sys_error(NULL); + channel->offset = dest; + channel->curr = channel->max = channel->buff; + } + return Atom(0); +} + +value pos_in(channel) /* ML */ + struct channel * channel; +{ + return Val_long(channel->offset - (channel->max - channel->curr)); +} + +value close_in(channel) /* ML */ + struct channel * channel; +{ + close(channel->fd); + stat_free((char *) channel); + return Atom(0); +} + +value input_scan_line(channel) /* ML */ + struct channel * channel; +{ + char * p; + int n; + + p = channel->curr; + do { + if (p >= channel->max) { + /* No more characters available in the buffer */ + if (channel->curr > channel->buff) { + /* Try to make some room in the buffer by shifting the unread + portion at the beginning */ + bcopy(channel->curr, channel->buff, channel->max - channel->curr); + n = channel->curr - channel->buff; + channel->curr -= n; + channel->max -= n; + p -= n; + } + if (channel->max >= channel->end) { + /* Buffer is full, no room to read more characters from the input. + Return the number of characters in the buffer, with negative + sign to indicate that no newline was encountered. */ + return Val_long(-(channel->max - channel->curr)); + } + /* Fill the buffer as much as possible */ + n = really_read(channel->fd, channel->max, channel->end - channel->max); + if (n == 0) { + /* End-of-file encountered. Return the number of characters in the + buffer, with negative sign since we haven't encountered + a newline. */ + return Val_long(-(channel->max - channel->curr)); + } + channel->offset += n; + channel->max += n; + } + } while (*p++ != '\n'); + /* Found a newline. Return the length of the line, newline included. */ + return Val_long(p - channel->curr); +} diff --git a/byterun/io.h b/byterun/io.h new file mode 100644 index 0000000000..d679886cbc --- /dev/null +++ b/byterun/io.h @@ -0,0 +1,52 @@ +/* Buffered input/output */ + +#ifndef _io_ +#define _io_ + + +#include "misc.h" +#include "mlvalues.h" + +#ifndef IO_BUFFER_SIZE +#define IO_BUFFER_SIZE 4096 +#endif + +struct channel { + int fd; /* Unix file descriptor */ + long offset; /* Absolute position of fd in the file */ + char * curr; /* Current position in the buffer */ + char * max; /* Logical end of the buffer */ + char * end; /* Physical end of the buffer */ + char buff[IO_BUFFER_SIZE]; /* The buffer itself */ +}; + +/* For an output channel: + [offset] is the absolute position of the beginning of the buffer [buff]. + For an input channel: + [offset] is the absolute position of the logical end of the buffer [max]. +*/ + +#define putch(channel, ch) \ + { if ((channel)->curr >= (channel)->end) flush(channel); \ + *((channel)->curr)++ = (ch); \ + if ((channel)->curr > (channel)->max) (channel)->max = (channel)->curr; } + +#define getch(channel) \ + ((channel)->curr >= (channel)->max \ + ? refill(channel) \ + : (unsigned char) *((channel))->curr++) + +struct channel * open_descr P((int)); +value flush P((struct channel *)); +void putword P((struct channel *, uint32)); +void putblock P((struct channel *, char *, unsigned)); +unsigned char refill P((struct channel *)); +value pos_out P((struct channel *)); +value seek_out P((struct channel *, value)); +uint32 getword P((struct channel *)); +unsigned getblock P((struct channel *, char *, unsigned)); +int really_getblock P((struct channel *, char *, unsigned long)); +value close_in P((struct channel *)); + + +#endif /* _io_ */ diff --git a/byterun/main.c b/byterun/main.c new file mode 100644 index 0000000000..f91ada34c2 --- /dev/null +++ b/byterun/main.c @@ -0,0 +1,229 @@ +/* Start-up code */ + +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <fcntl.h> +#include <unistd.h> +#include "alloc.h" +#include "exec.h" +#include "fail.h" +#include "gc_ctrl.h" +#include "interp.h" +#include "intext.h" +#include "io.h" +#include "misc.h" +#include "mlvalues.h" +#include "stacks.h" +#include "sys.h" + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +header_t first_atoms[256]; +code_t start_code; +asize_t code_size; + +static void init_atoms() +{ + int i; + for(i = 0; i < 256; i++) first_atoms[i] = Make_header(0, i, White); +} + +static unsigned long read_size(p) + unsigned char * p; +{ + return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) + + ((unsigned long) p[2] << 8) + p[3]; +} + +#define FILE_NOT_FOUND (-1) +#define TRUNCATED_FILE (-2) +#define BAD_MAGIC_NUM (-3) + +static int read_trailer(fd, trail) + int fd; + struct exec_trailer * trail; +{ + char buffer[TRAILER_SIZE]; + + lseek(fd, (long) -TRAILER_SIZE, 2); + if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return TRUNCATED_FILE; + trail->code_size = read_size(buffer); + trail->data_size = read_size(buffer+4); + trail->symbol_size = read_size(buffer+8); + trail->debug_size = read_size(buffer+12); + if (strncmp(buffer + 16, EXEC_MAGIC, 12) == 0) + return 0; + else + return BAD_MAGIC_NUM; +} + +extern char * searchpath(); + +int attempt_open(name, trail, do_open_script) + char ** name; + struct exec_trailer * trail; + int do_open_script; +{ + char * truename; + int fd; + int err; + char buf [2]; + + truename = searchpath(*name); + if (truename == 0) truename = *name; else *name = truename; + fd = open(truename, O_RDONLY | O_BINARY); + if (fd == -1) return FILE_NOT_FOUND; + if (!do_open_script){ + err = read (fd, buf, 2); + if (err < 2) return TRUNCATED_FILE; + if (buf [0] == '#' && buf [1] == '!') return BAD_MAGIC_NUM; + } + err = read_trailer(fd, trail); + if (err != 0) { close(fd); return err; } + return fd; +} + +/* Invocation of camlrun: 4 cases. + + 1. runtime + bytecode + user types: camlrun [options] bytecode args... + arguments: camlrun [options] bytecode args... + + 2. bytecode script + user types: bytecode args... + 2a (kernel 1) arguments: camlrun ./bytecode args... + 2b (kernel 2) arguments: bytecode bytecode args... + + 3. concatenated runtime and bytecode + user types: composite args... + arguments: composite args... + +Algorithm: + 1- If argument 0 is a valid byte-code file that does not start with #!, + then we are in case 3 and we pass the same command line to the + Caml Light program. + 2- In all other cases, we parse the command line as: + (whatever) [options] bytecode args... + and we strip "(whatever) [options]" from the command line. + +*/ + +#ifdef HAS_UI +int caml_main(argc, argv) +#else +int main(argc, argv) +#endif + int argc; + char * argv[]; +{ + int fd; + struct exec_trailer trail; + int i; + struct longjmp_buffer raise_buf; + struct channel * chan; + int verbose_init = 0, percent_free_init = Percent_free_def; + long minor_heap_init = Minor_heap_def, heap_chunk_init = Heap_chunk_def; + +#ifdef DEBUG + verbose_init = 1; +#endif + + i = 0; + fd = attempt_open(&argv[0], &trail, 0); + + if (fd < 0) { + + for(i = 1; i < argc && argv[i][0] == '-'; i++) { + switch(argv[i][1]) { +#ifdef DEBUG + case 't': { + extern int trace_flag; + trace_flag = 1; + break; + } +#endif + case 'v': + verbose_init = 1; + break; + case 'V': + fprintf(stderr, "The Caml 1999 runtime system, version %s\n", + "1"); + exit(0); + default: + fatal_error_arg("Unknown option %s.\n", argv[i]); + } + } + + if (argv[i] == 0) + fatal_error("No bytecode file specified.\n"); + + fd = attempt_open(&argv[i], &trail, 1); + + switch(fd) { + case FILE_NOT_FOUND: + fatal_error_arg("Fatal error: cannot find file %s\n", argv[i]); + break; + case TRUNCATED_FILE: + case BAD_MAGIC_NUM: + fatal_error_arg( + "Fatal error: the file %s is not a bytecode executable file\n", + argv[i]); + break; + } + } + + /* Runtime options. The option letter is the first letter of the + last word of the ML name of the option (see [lib/gc.mli]). */ + + { char *opt = getenv ("CAMLRUNPARAM"); + if (opt != NULL){ + while (*opt != '\0'){ + switch (*opt++){ + case 's': sscanf (opt, "=%ld", &minor_heap_init); break; + case 'i': sscanf (opt, "=%ld", &heap_chunk_init); break; + case 'o': sscanf (opt, "=%d", &percent_free_init); break; + case 'v': sscanf (opt, "=%d", &verbose_init); break; + } + } + } + } + + if (setjmp(raise_buf.buf) == 0) { + + external_raise = &raise_buf; + + init_gc (minor_heap_init, heap_chunk_init, percent_free_init, + verbose_init); + init_stack(); + init_atoms(); + + lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size + + trail.symbol_size + trail.debug_size), 2); + + code_size = trail.code_size; + start_code = (code_t) stat_alloc(code_size); + if (read(fd, (char *) start_code, code_size) != code_size) + fatal_error("Fatal error: truncated bytecode file.\n"); + +#ifdef BIG_ENDIAN + fixup_endianness(start_code, code_size); +#endif + + chan = open_descr(fd); + global_data = input_value(chan); + close_in(chan); + + sys_init(argv + i); + interprete(start_code, code_size); + sys_exit(Val_int(0)); + + } else { + + fatal_error_arg("Fatal error: uncaught exception %s.\n", + String_val(Field(Field(exn_bucket, 0), 0))); + } +} + diff --git a/byterun/major_gc.c b/byterun/major_gc.c new file mode 100644 index 0000000000..11dd32b790 --- /dev/null +++ b/byterun/major_gc.c @@ -0,0 +1,305 @@ +#include "config.h" +#include "fail.h" +#include "freelist.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "roots.h" + +#ifdef __STDC__ +#include <limits.h> +#else +#ifdef SIXTYFOUR +#define LONG_MAX 0x7FFFFFFFFFFFFFFF +#else +#define LONG_MAX 0x7FFFFFFF +#endif +#endif + +int percent_free; +long major_heap_increment; +char *heap_start, *heap_end; +char *page_table; +asize_t page_table_size; +char *gc_sweep_hp; +int gc_phase; +static value *gray_vals; +value *gray_vals_cur, *gray_vals_end; +static asize_t gray_vals_size; +static int heap_is_pure; /* The heap is pure if the only gray objects + below [markhp] are also in [gray_vals]. */ +unsigned long allocated_words; +unsigned long extra_heap_memory; +extern char *fl_merge; /* Defined in freelist.c. */ + +static char *markhp, *chunk, *limit; + +static void realloc_gray_vals () +{ + value *new; + + Assert (gray_vals_cur == gray_vals_end); + if (gray_vals_size < stat_heap_size / 128){ + gc_message ("Growing gray_vals to %ldk\n", + (long) gray_vals_size * sizeof (value) / 512); + new = (value *) realloc ((char *) gray_vals, + 2 * gray_vals_size * sizeof (value)); + if (new == NULL){ + gc_message ("No room for growing gray_vals\n", 0); + gray_vals_cur = gray_vals; + heap_is_pure = 0; + }else{ + gray_vals = new; + gray_vals_cur = gray_vals + gray_vals_size; + gray_vals_size *= 2; + gray_vals_end = gray_vals + gray_vals_size; + } + }else{ + gray_vals_cur = gray_vals + gray_vals_size / 2; + heap_is_pure = 0; + } +} + +void darken (v) + value v; +{ + if (Is_block (v) && Is_in_heap (v) && Is_white_val (v)){ + Hd_val (v) = Grayhd_hd (Hd_val (v)); + *gray_vals_cur++ = v; + if (gray_vals_cur >= gray_vals_end) realloc_gray_vals (); + } +} + +static void darken_root (p, v) + value *p; + value v; +{ + darken (v); +} + +static void start_cycle () +{ + Assert (gray_vals_cur == gray_vals); + Assert (Is_white_val (global_data)); + darken (global_data); + scan_local_roots (darken_root); + gc_phase = Phase_mark; + markhp = NULL; +} + +static void mark_slice (work) + long work; +{ + value v, child; + mlsize_t i; + + while (work > 0){ + if (gray_vals_cur > gray_vals){ + v = *--gray_vals_cur; + Assert (Is_gray_val (v)); + Hd_val (v) = Blackhd_hd (Hd_val (v)); + if (Tag_val (v) < No_scan_tag){ + for (i = Wosize_val (v); i > 0;){ + --i; + child = Field (v, i); + darken (child); + } + } + work -= Whsize_val (v); + }else if (markhp != NULL){ + if (markhp == limit){ + chunk = (((heap_chunk_head *) chunk) [-1]).next; + if (chunk == NULL){ + markhp = NULL; + }else{ + markhp = chunk; + limit = chunk + (((heap_chunk_head *) chunk) [-1]).size; + } + }else{ + if (Is_gray_val (Val_hp (markhp))){ + Assert (gray_vals_cur == gray_vals); + *gray_vals_cur++ = Val_hp (markhp); + } + markhp += Bhsize_hp (markhp); + } + }else if (!heap_is_pure){ + heap_is_pure = 1; + chunk = heap_start; + markhp = chunk; + limit = chunk + (((heap_chunk_head *) chunk) [-1]).size; + }else{ + /* Marking is done. */ + gc_sweep_hp = heap_start; + fl_init_merge (); + gc_phase = Phase_sweep; + chunk = heap_start; + gc_sweep_hp = chunk; + limit = chunk + (((heap_chunk_head *) chunk) [-1]).size; + work = 0; + } + } +} + +static void sweep_slice (work) + long work; +{ + char *hp; + header_t hd; + + while (work > 0){ + if (gc_sweep_hp < limit){ + hp = gc_sweep_hp; + hd = Hd_hp (hp); + work -= Whsize_hd (hd); + gc_sweep_hp += Bhsize_hd (hd); + switch (Color_hd (hd)){ + case White: + if (Tag_hd (hd) == Final_tag){ + Final_fun (Val_hp (hp)) (Val_hp (hp)); + } + gc_sweep_hp = fl_merge_block (Bp_hp (hp)); + break; + case Gray: + Assert (0); /* Fall through to Black when not in debug mode. */ + case Black: + Hd_hp (hp) = Whitehd_hd (hd); + break; + case Blue: + /* Only the blocks of the free-list are blue. See [freelist.c]. */ + fl_merge = Bp_hp (hp); + break; + } + Assert (gc_sweep_hp <= limit); + }else{ + chunk = (((heap_chunk_head *) chunk) [-1]).next; + if (chunk == NULL){ + /* Sweeping is done. Start the next cycle. */ + ++ stat_major_collections; + work = 0; + start_cycle (); + }else{ + gc_sweep_hp = chunk; + limit = chunk + (((heap_chunk_head *) chunk) [-1]).size; + } + } + } +} + +void major_collection_slice () +{ + /* Free memory at the start of the GC cycle: + FM = stat_heap_size * percent_free / 100 * 2/3 + Proportion of free memory consumed since the previous slice: + PH = allocated_words / FM + Proportion of extra-heap memory consumed since the previous slice: + PE = extra_heap_memory / stat_heap_size + Proportion of total work to do in this slice: + P = PH + PE + Amount of marking work for the GC cycle: + MW = stat_heap_size * (100 - percent_free) / 100 + Amount of sweeping work for the GC cycle: + SW = stat_heap_size + Amount of marking work for this slice: + MS = MW * 2 * P + MS = 2 * (100 - percent_free) + * (allocated_words * 3 / percent_free / 2 + + 100 * extra_heap_memory) + Amount of sweeping work for this slice: + SS = SW * 2 * P + SS = 2 * 100 + * (allocated_words * 3 / percent_free / 2 + + 100 * extra_heap_memory) + This slice will either mark MS words or sweep SS words. + */ + +#define Margin 100 /* Make it a little faster to be on the safe side. */ + + if (gc_phase == Phase_mark){ + mark_slice (2 * (100 - percent_free) + * (allocated_words * 3 / percent_free / 2 + + 100 * extra_heap_memory) + + Margin); + gc_message ("!", 0); + }else{ + Assert (gc_phase == Phase_sweep); + sweep_slice (200 * (allocated_words * 3 / percent_free / 2 + + 100 * extra_heap_memory) + + Margin); + gc_message ("$", 0); + } + stat_major_words += allocated_words; + allocated_words = 0; + extra_heap_memory = 0; +} + +/* The minor heap must be empty when this function is called. */ +void finish_major_cycle () +{ + if (gc_phase == Phase_mark) mark_slice (LONG_MAX); + Assert (gc_phase == Phase_sweep); + sweep_slice (LONG_MAX); + stat_major_words += allocated_words; + allocated_words = 0; +} + +asize_t round_heap_chunk_size (request) + asize_t request; +{ Assert (major_heap_increment >= Heap_chunk_min); + if (request < major_heap_increment){ + Assert (major_heap_increment % Page_size == 0); + return major_heap_increment; + }else if (request <= Heap_chunk_max){ + return ((request + Page_size - 1) >> Page_log) << Page_log; + }else{ + raise_out_of_memory (); + } +} + +void init_major_heap (heap_size) + asize_t heap_size; +{ + asize_t i; + + stat_heap_size = round_heap_chunk_size (heap_size); + Assert (stat_heap_size % Page_size == 0); + heap_start = aligned_malloc (stat_heap_size + sizeof (heap_chunk_head), + sizeof (heap_chunk_head)); + if (heap_start == NULL) + fatal_error ("Fatal error: not enough memory for the initial heap.\n"); + heap_start += sizeof (heap_chunk_head); + Assert ((unsigned long) heap_start % Page_size == 0); + (((heap_chunk_head *) heap_start) [-1]).size = stat_heap_size; + (((heap_chunk_head *) heap_start) [-1]).next = NULL; + heap_end = heap_start + stat_heap_size; + Assert ((unsigned long) heap_end % Page_size == 0); +#ifdef SIXTEEN + page_table_size = 640L * 1024L / Page_size + 1; +#else + page_table_size = 4 * stat_heap_size / Page_size; +#endif + page_table = (char *) malloc (page_table_size); + if (page_table == NULL){ + fatal_error ("Fatal error: not enough memory for the initial heap.\n"); + } + for (i = 0; i < page_table_size; i++){ + page_table [i] = Not_in_heap; + } + for (i = Page (heap_start); i < Page (heap_end); i++){ + page_table [i] = In_heap; + } + Hd_hp (heap_start) = Make_header (Wosize_bhsize (stat_heap_size), 0, Blue); + fl_init_merge (); + fl_merge_block (Bp_hp (heap_start)); + /* We start the major GC in the marking phase, just after the roots have been + darkened. (Since there are no roots, we don't have to darken anything.) */ + gc_phase = Phase_mark; + gray_vals_size = 2048; + gray_vals = (value *) malloc (gray_vals_size * sizeof (value)); + gray_vals_cur = gray_vals; + gray_vals_end = gray_vals + gray_vals_size; + heap_is_pure = 1; + allocated_words = 0; + extra_heap_memory = 0; +} diff --git a/byterun/major_gc.h b/byterun/major_gc.h new file mode 100644 index 0000000000..0c39a87de1 --- /dev/null +++ b/byterun/major_gc.h @@ -0,0 +1,42 @@ +#ifndef _major_gc_ +#define _major_gc_ + + +#include "freelist.h" +#include "misc.h" + +typedef struct { + asize_t size; + char *next; +} heap_chunk_head; + +extern int gc_phase; +extern unsigned long allocated_words; +extern unsigned long extra_heap_memory; + +#define Phase_mark 0 +#define Phase_sweep 1 + +extern char *heap_start; +extern char *heap_end; +extern unsigned long total_heap_size; +extern char *page_table; +extern asize_t page_table_size; +extern char *gc_sweep_hp; + +#define In_heap 1 +#define Not_in_heap 0 +#define Page(p) (((addr) (p) - (addr) heap_start) >> Page_log) +#define Is_in_heap(p) \ + ((addr)(p) >= (addr)heap_start && (addr)(p) < (addr)heap_end \ + && page_table [Page (p)] == In_heap) + +void init_major_heap P((asize_t)); +asize_t round_heap_chunk_size P((asize_t)); +void darken P((value)); +void major_collection_slice P((void)); +void major_collection P((void)); +void finish_major_cycle P((void)); + + +#endif /* _major_gc_ */ diff --git a/byterun/memory.c b/byterun/memory.c new file mode 100644 index 0000000000..aacf05eba7 --- /dev/null +++ b/byterun/memory.c @@ -0,0 +1,205 @@ +#include <string.h> +#include "fail.h" +#include "freelist.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "memory.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" + +/* Allocate more memory from malloc for the heap. + Return a block of at least the requested size (in words). + Return NULL when out of memory. +*/ +static char *expand_heap (request) + mlsize_t request; +{ + char *mem; + char *new_page_table; + asize_t new_page_table_size; + asize_t malloc_request; + asize_t i, more_pages; + + malloc_request = round_heap_chunk_size (Bhsize_wosize (request)); + gc_message ("Growing heap to %ldk\n", + (stat_heap_size + malloc_request) / 1024); + mem = aligned_malloc (malloc_request + sizeof (heap_chunk_head), + sizeof (heap_chunk_head)); + if (mem == NULL){ + gc_message ("No room for growing heap\n", 0); + return NULL; + } + mem += sizeof (heap_chunk_head); + (((heap_chunk_head *) mem) [-1]).size = malloc_request; + Assert (Wosize_bhsize (malloc_request) >= request); + Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Blue); + + if (mem < heap_start){ + more_pages = -Page (mem); + }else if (Page (mem + malloc_request) > page_table_size){ + Assert (mem >= heap_end); + more_pages = Page (mem + malloc_request) - page_table_size; + }else{ + more_pages = 0; + } + + if (more_pages != 0){ + new_page_table_size = page_table_size + more_pages; + new_page_table = (char *) malloc (new_page_table_size); + if (new_page_table == NULL){ + gc_message ("No room for growing page table\n", 0); + free (mem); + return NULL; + } + } else { + new_page_table = NULL; + new_page_table_size = 0; + } + + if (mem < heap_start){ + Assert (more_pages != 0); + for (i = 0; i < more_pages; i++){ + new_page_table [i] = Not_in_heap; + } + bcopy (page_table, new_page_table + more_pages, page_table_size); + (((heap_chunk_head *) mem) [-1]).next = heap_start; + heap_start = mem; + }else{ + char **last; + char *cur; + + if (mem >= heap_end) heap_end = mem + malloc_request; + if (more_pages != 0){ + for (i = page_table_size; i < new_page_table_size; i++){ + new_page_table [i] = Not_in_heap; + } + bcopy (page_table, new_page_table, page_table_size); + } + last = &heap_start; + cur = *last; + while (cur != NULL && cur < mem){ + last = &((((heap_chunk_head *) cur) [-1]).next); + cur = *last; + } + (((heap_chunk_head *) mem) [-1]).next = cur; + *last = mem; + } + + if (more_pages != 0){ + free (page_table); + page_table = new_page_table; + page_table_size = new_page_table_size; + } + + for (i = Page (mem); i < Page (mem + malloc_request); i++){ + page_table [i] = In_heap; + } + stat_heap_size += malloc_request; + return Bp_hp (mem); +} + +value alloc_shr (wosize, tag) + mlsize_t wosize; + tag_t tag; +{ + char *hp, *new_block; + + hp = fl_allocate (wosize); + if (hp == NULL){ + new_block = expand_heap (wosize); + if (new_block == NULL) raise_out_of_memory (); + fl_add_block (new_block); + hp = fl_allocate (wosize); + } + + Assert (Is_in_heap (Val_hp (hp))); + + if (gc_phase == Phase_mark || (addr)hp >= (addr)gc_sweep_hp){ + Hd_hp (hp) = Make_header (wosize, tag, Black); + }else{ + Hd_hp (hp) = Make_header (wosize, tag, White); + } + allocated_words += Whsize_wosize (wosize); + if (allocated_words > Wsize_bsize (minor_heap_size)) force_minor_gc (); + return Val_hp (hp); +} + +/* Use this function to tell the major GC to speed up when you use + finalized objects to automatically deallocate extra-heap objects. + The GC will do at least one cycle every [max] allocated words; + [mem] is the number of words allocated this time. + Note that only [mem/max] is relevant. You can use numbers of bytes + (or kilobytes, ...) instead of words. You can change units between + calls to [adjust_collector_speed]. +*/ +void adjust_gc_speed (mem, max) + mlsize_t mem, max; +{ + if (max == 0) max = 1; + if (mem > max) mem = max; + extra_heap_memory += ((float) mem / max) * stat_heap_size; + if (extra_heap_memory > stat_heap_size){ + extra_heap_memory = stat_heap_size; + } + if (extra_heap_memory > Wsize_bsize (minor_heap_size) / 2) force_minor_gc (); +} + +/* You must use [initialize] to store the initial value in a field of + a shared block, unless you are sure the value is not a young block. + A block value [v] is a shared block if and only if [Is_in_heap (v)] + is true. +*/ +/* [initialize] never calls the GC, so you may call it while an object is + unfinished (i.e. just after a call to [alloc_shr].) */ +void initialize (fp, val) + value *fp; + value val; +{ + *fp = val; + Assert (Is_in_heap (fp)); + if (Is_block (val) && Is_young (val)){ + *ref_table_ptr++ = fp; + if (ref_table_ptr >= ref_table_limit){ + realloc_ref_table (); + } + } +} + +/* You must use [modify] to change a field of an existing shared block, + unless you are sure the value being overwritten is not a shared block and + the value being written is not a young block. */ +/* [modify] never calls the GC. */ +void modify (fp, val) + value *fp; + value val; +{ + Modify (fp, val); +} + +char *stat_alloc (sz) + asize_t sz; +{ + char *result = (char *) malloc (sz); + + if (result == NULL) raise_out_of_memory (); + return result; +} + +void stat_free (blk) + char * blk; +{ + free (blk); +} + +char *stat_resize (blk, sz) + char *blk; + asize_t sz; +{ + char *result = (char *) realloc (blk, sz); + + if (result == NULL) raise_out_of_memory (); + return result; +} + diff --git a/byterun/memory.h b/byterun/memory.h new file mode 100644 index 0000000000..5df199e02e --- /dev/null +++ b/byterun/memory.h @@ -0,0 +1,88 @@ +/* Allocation macros and functions */ + +#ifndef _memory_ +#define _memory_ + + +#include "config.h" +#include "gc.h" +#include "major_gc.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" + +value alloc_shr P((mlsize_t, tag_t)); +void adjust_gc_speed P((mlsize_t, mlsize_t)); +void modify P((value *, value)); +void initialize P((value *, value)); +char * stat_alloc P((asize_t)); /* Size in bytes. */ +void stat_free P((char *)); +char * stat_resize P((char *, asize_t)); /* Size in bytes. */ + + +#define Alloc_small(result, wosize, tag) { \ + char *_res_ = young_ptr; \ + young_ptr += Bhsize_wosize (wosize); \ + if (young_ptr > young_end){ \ + Setup_for_gc; \ + minor_collection (); \ + Restore_after_gc; \ + _res_ = young_ptr; \ + young_ptr += Bhsize_wosize (wosize); \ + } \ + Hd_hp (_res_) = Make_header ((wosize), (tag), Black); \ + (result) = Val_hp (_res_); \ +} + +/* You must use [Modify] to change a field of an existing shared block, + unless you are sure the value being overwritten is not a shared block and + the value being written is not a young block. */ +/* [Modify] never calls the GC. */ + +#define Modify(fp, val) { \ + value _old_ = *(fp); \ + *(fp) = (val); \ + if (Is_in_heap (fp)){ \ + if (gc_phase == Phase_mark) darken (_old_); \ + if (Is_block (val) && Is_young (val) \ + && ! (Is_block (_old_) && Is_young (_old_))){ \ + *ref_table_ptr++ = (fp); \ + if (ref_table_ptr >= ref_table_limit){ \ + Assert (ref_table_ptr == ref_table_limit); \ + realloc_ref_table (); \ + } \ + } \ + } \ +} \ + +/* [Push_roots] and [Pop_roots] are used for C variables that are GC roots. + * It must contain all values in C local variables at the time the minor GC is + * called. + * Usage: + * At the end of the declarations of your C local variables, add + * [ Push_roots (variable_name, size); ] + * The size is the number of declared roots. They are accessed as + * [ variable_name [0] ... variable_name [size - 1] ]. + * The [variable_name] and the [size] must not be [ _ ]. + * Just before the function return, add a call to [Pop_roots]. + */ + +extern value *local_roots; + +#define Push_roots(name, size) \ + value name [(size) + 2]; \ + { long _; for (_ = 0; _ < (size); name [_++] = Val_long (0)); } \ + name [(size)] = (value) (size); \ + name [(size) + 1] = (value) local_roots; \ + local_roots = &(name [(size)]); + +#define Pop_roots() {local_roots = (value *) local_roots [1]; } + +/* [register_global_root] registers a global C variable as a memory root + for the duration of the program. */ + +void register_global_root P((value *)); + + +#endif /* _memory_ */ + diff --git a/byterun/meta.c b/byterun/meta.c new file mode 100644 index 0000000000..2da8c15c91 --- /dev/null +++ b/byterun/meta.c @@ -0,0 +1,93 @@ +/* Primitives for the toplevel */ + +#include "alloc.h" +#include "interp.h" +#include "major_gc.h" +#include "memory.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "prims.h" + +value get_global_data(unit) /* ML */ + value unit; +{ + return global_data; +} + +value execute_bytecode(prog, len) /* ML */ + value prog, len; +{ +#if defined(BIG_ENDIAN) + fixup_endianness((code_t) prog, (asize_t) Long_val(len)); +#endif + return interprete((code_t) prog, (asize_t) Long_val(len)); +} + +value realloc_global(size) /* ML */ + value size; +{ + mlsize_t requested_size, actual_size, i; + value new_global_data; + + requested_size = Long_val(size); + actual_size = Wosize_val(global_data); + if (requested_size >= actual_size) { + requested_size = (requested_size + 0x100) & 0xFFFFFF00; + new_global_data = alloc_shr(requested_size, 0); + for (i = 0; i < actual_size; i++) + initialize(&Field(new_global_data, i), Field(global_data, i)); + for (i = actual_size; i < requested_size; i++){ + Field (new_global_data, i) = Val_long (0); + } + global_data = new_global_data; + } + return Atom(0); +} + +value static_alloc(size) /* ML */ + value size; +{ + return (value) stat_alloc((asize_t) Long_val(size)); +} + +value static_free(blk) /* ML */ + value blk; +{ + stat_free((char *) blk); + return Atom(0); +} + +value static_resize(blk, new_size) /* ML */ + value blk, new_size; +{ + return (value) stat_resize((char *) blk, (asize_t) Long_val(new_size)); +} + +value obj_is_block(arg) /* ML */ + value arg; +{ + return Atom(Is_block(arg)); +} + +value obj_block(tag, size) /* ML */ + value tag, size; +{ + value res; + mlsize_t sz, i; + tag_t tg; + + sz = Long_val(size); + tg = Long_val(tag); + if (sz == 0) return Atom(tg); + res = alloc(sz, tg); + for (i = 0; i < sz; i++) + Field(res, i) = Val_long(0); + + return res; +} + +value available_primitives() /* ML */ +{ + return copy_string_array(names_of_cprim); +} diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c new file mode 100644 index 0000000000..f2fd8fbd31 --- /dev/null +++ b/byterun/minor_gc.c @@ -0,0 +1,156 @@ +#include <string.h> +#include "config.h" +#include "fail.h" +#include "gc.h" +#include "gc_ctrl.h" +#include "major_gc.h" +#include "memory.h" +#include "minor_gc.h" +#include "misc.h" +#include "mlvalues.h" +#include "roots.h" + +asize_t minor_heap_size; +char *young_start = NULL, *young_end, *young_ptr = NULL; +static value **ref_table = NULL, **ref_table_end, **ref_table_threshold; +value **ref_table_ptr = NULL, **ref_table_limit; +static asize_t ref_table_size, ref_table_reserve; + +void set_minor_heap_size (size) + asize_t size; +{ + char *new_heap; + value **new_table; + + Assert (size >= Minor_heap_min); + Assert (size <= Minor_heap_max); + Assert (size % sizeof (value) == 0); + if (young_ptr != young_start) minor_collection (); + Assert (young_ptr == young_start); + new_heap = (char *) stat_alloc (size); + if (young_start != NULL){ + stat_free ((char *) young_start); + } + young_start = new_heap; + young_end = new_heap + size; + young_ptr = young_start; + minor_heap_size = size; + + ref_table_size = minor_heap_size / sizeof (value) / 8; + ref_table_reserve = 256; + new_table = (value **) stat_alloc ((ref_table_size + ref_table_reserve) + * sizeof (value *)); + if (ref_table != NULL) stat_free ((char *) ref_table); + ref_table = new_table; + ref_table_ptr = ref_table; + ref_table_threshold = ref_table + ref_table_size; + ref_table_limit = ref_table_threshold; + ref_table_end = ref_table + ref_table_size + ref_table_reserve; +} + +static void oldify (p, v) + value *p; + value v; +{ + value result; + mlsize_t i; + + tail_call: + if (Is_block (v) && Is_young (v)){ + Assert (Hp_val (v) < young_ptr); + if (Is_blue_val (v)){ /* Already forwarded ? */ + *p = Field (v, 0); /* Then the forward pointer is the first field. */ + }else if (Tag_val (v) >= No_scan_tag){ + result = alloc_shr (Wosize_val (v), Tag_val (v)); + bcopy (Bp_val (v), Bp_val (result), Bosize_val (v)); + Hd_val (v) = Bluehd_hd (Hd_val (v)); /* Put the forward flag. */ + Field (v, 0) = result; /* And the forward pointer. */ + *p = result; + }else{ + /* We can do recursive calls before all the fields are filled, because + we will not be calling the major GC. */ + value field0 = Field (v, 0); + mlsize_t sz = Wosize_val (v); + + result = alloc_shr (sz, Tag_val (v)); + *p = result; + Hd_val (v) = Bluehd_hd (Hd_val (v)); /* Put the forward flag. */ + Field (v, 0) = result; /* And the forward pointer. */ + if (sz == 1){ + p = &Field (result, 0); + v = field0; + goto tail_call; + }else{ + oldify (&Field (result, 0), field0); + for (i = 1; i < sz - 1; i++){ + oldify (&Field (result, i), Field (v, i)); + } + p = &Field (result, i); + v = Field (v, i); + goto tail_call; + } + } + }else{ + *p = v; + } +} + +void minor_collection () +{ + value **r; + struct longjmp_buffer raise_buf; + struct longjmp_buffer *old_external_raise; + long prev_alloc_words = allocated_words; + + if (setjmp(raise_buf.buf)) { + fatal_error ("Fatal error: out of memory.\n"); + } + old_external_raise = external_raise; + external_raise = &raise_buf; + + gc_message ("<", 0); + scan_local_roots (oldify); + for (r = ref_table; r < ref_table_ptr; r++) oldify (*r, **r); + stat_minor_words += Wsize_bsize (young_ptr - young_start); + young_ptr = young_start; + ref_table_ptr = ref_table; + ref_table_limit = ref_table_threshold; + gc_message (">", 0); + + external_raise = old_external_raise; + + stat_promoted_words += allocated_words - prev_alloc_words; + ++ stat_minor_collections; + major_collection_slice (); + force_minor_flag = 0; +} + +void realloc_ref_table () +{ Assert (ref_table_ptr == ref_table_limit); + Assert (ref_table_limit <= ref_table_end); + Assert (ref_table_limit >= ref_table_threshold); + + if (ref_table_limit == ref_table_threshold){ + gc_message ("ref_table threshold crossed\n", 0); + ref_table_limit = ref_table_end; + force_minor_gc (); + }else{ /* This will never happen. */ + asize_t sz; + asize_t cur_ptr = ref_table_ptr - ref_table; + Assert (force_minor_flag); + Assert (something_to_do); + ref_table_reserve += 1024; + sz = (ref_table_size + ref_table_reserve) * sizeof (value *); + gc_message ("Growing ref_table to %ldk\n", (long) sz / 1024); +#ifdef MAX_MALLOC_SIZE + if (sz > MAX_MALLOC_SIZE) ref_table = NULL; + else +#endif + ref_table = (value **) realloc ((char *) ref_table, sz); + if (ref_table == NULL) 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; + ref_table_ptr = ref_table + cur_ptr; + ref_table_limit = ref_table_end; + } +} diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h new file mode 100644 index 0000000000..112ba58a97 --- /dev/null +++ b/byterun/minor_gc.h @@ -0,0 +1,19 @@ +#ifndef _minor_gc_ +#define _minor_gc_ + + +#include "misc.h" + +extern char *young_start, *young_ptr, *young_end; +extern value **ref_table_ptr, **ref_table_limit; +extern asize_t minor_heap_size; + +#define Is_young(val) \ + ((addr)(val) > (addr)young_start && (addr)(val) < (addr)young_end) + +extern void set_minor_heap_size P((asize_t)); +extern void minor_collection P((void)); +extern void realloc_ref_table P((void)); + + +#endif /* _minor_gc_ */ diff --git a/byterun/misc.c b/byterun/misc.c new file mode 100644 index 0000000000..c53452acd0 --- /dev/null +++ b/byterun/misc.c @@ -0,0 +1,166 @@ +#include <stdio.h> +#include "config.h" +#include "misc.h" +#ifdef HAS_UI +#include "ui.h" +#endif + +#ifdef DEBUG + +void failed_assert (expr, file, line) + char *expr, *file; + int line; +{ + fprintf (stderr, "Assertion failed: %s; file %s; line %d\n", + expr, file, line); + exit (100); +} + +static unsigned long seed = 0x12345; + +unsigned long not_random () +{ + seed = seed * 65537 + 12345; + return seed; +} + +#endif + +int verb_gc; +int Volatile something_to_do = 0; +int Volatile force_minor_flag = 0; + +void force_minor_gc () +{ + force_minor_flag = 1; + something_to_do = 1; +} + +void gc_message (msg, arg) + char *msg; + unsigned long arg; +{ + if (verb_gc){ +#ifdef HAS_UI + ui_gc_message(msg, arg); +#else + fprintf (stderr, msg, arg); + fflush (stderr); +#endif + } +} + +void fatal_error (msg) + char * msg; +{ +#ifdef HAS_UI + ui_fatal_error("%s", msg); +#else + fprintf (stderr, "%s", msg); + exit(2); +#endif +} + +void fatal_error_arg (fmt, arg) + char * fmt, * arg; +{ +#ifdef HAS_UI + ui_fatal_error(fmt, arg); +#else + fprintf (stderr, fmt, arg); + exit(2); +#endif +} + +#ifdef USING_MEMMOV + +/* This should work on 64-bit machines as well as 32-bit machines. + It assumes a long is the natural size for memory reads and writes. +*/ +void memmov (dst, src, length) + char *dst, *src; + unsigned long length; +{ + unsigned long i; + + if ((unsigned long) dst <= (unsigned long) src){ + + /* Copy in ascending order. */ + if (((unsigned long) src - (unsigned long) dst) % sizeof (long) != 0){ + + /* The pointers are not equal modulo sizeof (long). + Copy byte by byte. */ + for (; length != 0; length--){ + *dst++ = *src++; + } + }else{ + + /* Copy the first few bytes. */ + i = (unsigned long) dst % sizeof (long); + if (i != 0){ + i = sizeof (long) - i; /* Number of bytes to copy. */ + if (i > length) i = length; /* Never copy more than length.*/ + for (; i != 0; i--){ + *dst++ = *src++; --length; + } + } Assert ((unsigned long) dst % sizeof (long) == 0); + Assert ((unsigned long) src % sizeof (long) == 0); + + /* Then copy as many entire words as possible. */ + for (i = length / sizeof (long); i > 0; i--){ + *(long *) dst = *(long *) src; + dst += sizeof (long); src += sizeof (long); + } + + /* Then copy the last few bytes. */ + for (i = length % sizeof (long); i > 0; i--){ + *dst++ = *src++; + } + } + }else{ /* Copy in descending order. */ + src += length; dst += length; + if (((unsigned long) dst - (unsigned long) src) % sizeof (long) != 0){ + + /* The pointers are not equal modulo sizeof (long). + Copy byte by byte. */ + for (; length > 0; length--){ + *--dst = *--src; + } + }else{ + + /* Copy the first few bytes. */ + i = (unsigned long) dst % sizeof (long); + if (i > length) i = length; /* Never copy more than length. */ + for (; i > 0; i--){ + *--dst = *--src; --length; + } + + /* Then copy as many entire words as possible. */ + for (i = length / sizeof (long); i > 0; i--){ + dst -= sizeof (long); src -= sizeof (long); + *(long *) dst = *(long *) src; + } + + /* Then copy the last few bytes. */ + for (i = length % sizeof (long); i > 0; i--){ + *--dst = *--src; + } + } + } +} + +#endif /* USING_MEMMOV */ + +char *aligned_malloc (size, modulo) + asize_t size; + int modulo; +{ + char *raw_mem; + unsigned long aligned_mem; + Assert (modulo < Page_size); + raw_mem = (char *) malloc (size + Page_size); + if (raw_mem == NULL) return NULL; + raw_mem += modulo; /* Address to be aligned */ + aligned_mem = (((unsigned long) raw_mem / Page_size + 1) * Page_size); + return (char *) (aligned_mem - modulo); +} diff --git a/byterun/misc.h b/byterun/misc.h new file mode 100644 index 0000000000..14c7bb3385 --- /dev/null +++ b/byterun/misc.h @@ -0,0 +1,90 @@ +/* Miscellaneous macros and variables. */ + +#ifndef _misc_ +#define _misc_ + + +#include "config.h" + +/* Standard definitions */ + +#ifdef __STDC__ +#include <stddef.h> +#include <stdlib.h> +#endif + +/* Function prototypes */ + +#ifdef __STDC__ +#define P(x) x +#else +#define P(x) () +#endif + +/* Basic types and constants */ + +#ifdef __STDC__ +typedef size_t asize_t; +#else +typedef int asize_t; +#endif + +#ifndef NULL +#define NULL 0 +#endif + +typedef char * addr; + +/* Volatile stuff */ + +#ifdef __STDC__ +#define Volatile volatile +#else +#define Volatile +#endif + +#ifdef __GNUC__ +/* Works only in GCC 2.5 and later */ +#define Noreturn __attribute ((noreturn)) +#else +#define Noreturn +#endif + +/* Assertions */ + +#ifdef DEBUG +#ifdef __STDC__ +#define Assert(x) if (!(x)) failed_assert ( #x , __FILE__, __LINE__) +#else +#ifndef __LINE__ +#define __LINE__ 0 +#endif +#ifndef __FILE__ +#define __FILE__ "(?)" +#endif +#define Assert(x) if (!(x)) failed_assert ("(?)" , __FILE__, __LINE__) +#endif +#else +#define Assert(x) +#endif + +void failed_assert P((char *, char *, int)) Noreturn; +void fatal_error P((char *)) Noreturn; +void fatal_error_arg P((char *, char *)) Noreturn; + +/* GC flags and messages */ + +extern int verb_gc; +extern int Volatile something_to_do; +extern int Volatile force_minor_flag; + +void force_minor_gc P((void)); +void gc_message P((char *, unsigned long)); + +/* Memory routines */ + +void memmov P((char *, char *, unsigned long)); +char * aligned_malloc P((asize_t, int)); +unsigned long not_random P((void)); + +#endif /* _misc_ */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h new file mode 100644 index 0000000000..f820f289a6 --- /dev/null +++ b/byterun/mlvalues.h @@ -0,0 +1,213 @@ +#ifndef _mlvalues_ +#define _mlvalues_ + + +#include "config.h" +#include "misc.h" + +/* Definitions + + word: Four bytes on 32 and 16 bit architectures, + eight bytes on 64 bit architectures. + long: A C long integer. + val: The ML representation of something. A long or a block or a pointer + outside the heap. If it is a block, it is the (encoded) address + of an object. If it is a long, it is encoded as well. + object: Something allocated. It always has a header and some + fields or some number of bytes (a multiple of the word size). + field: A word-sized val which is part of an object. + bp: Pointer to the first byte of an object. (a char *) + op: Pointer to the first field of an object. (a value *) + hp: Pointer to the header of an object. (a char *) + int32: Four bytes on all architectures. + + Remark: An object size is always a multiple of the word size, and at least + one word plus the header. + + bosize: Size (in bytes) of the "bytes" part. + wosize: Size (in words) of the "fields" part. + bhsize: Size (in bytes) of the object with its header. + whsize: Size (in words) of the object with its header. + + hd: A header. + tag: The value of the tag field of the header. + color: The value of the color field of the header. + This is for use only by the GC. +*/ + +typedef long value; +typedef unsigned long header_t; +typedef unsigned long mlsize_t; +typedef unsigned int tag_t; /* Actually, an unsigned char */ +typedef unsigned long color_t; +typedef unsigned long mark_t; + +typedef int int32; /* Not portable, but checked by autoconf. */ +typedef unsigned int uint32; /* Seems like a reasonable assumption anyway. */ + +/* Longs vs blocks. */ +#define Is_long(x) (((x) & 1) == 1) +#define Is_block(x) (((x) & 1) == 0) + +/* Conversion macro names are always of the form "to_from". */ +/* Example: Val_long as in "Val from long" or "Val of long". */ +#define Val_long(x) (((long)(x) << 1) + 1) +#define Long_val(x) ((x) >> 1) +#define Max_long ((1L << (8 * sizeof(value) - 2)) - 1) +#define Min_long (-(1L << (8 * sizeof(value) - 2))) +#define Val_int Val_long +#define Int_val(x) ((int) Long_val(x)) + +/* Structure of the header: + +For 16-bit and 32-bit architectures: + +--------+-------+-----+ + | wosize | color | tag | + +--------+-------+-----+ +bits 31 10 9 8 7 0 + +For 64-bit architectures: + + +--------+-------+-----+ + | wosize | color | tag | + +--------+-------+-----+ +bits 63 10 9 8 7 0 + +*/ + +#define Tag_hd(hd) ((tag_t) ((hd) & 0xFF)) +#define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10)) + +#define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */ +#define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ +#define Hd_bp(bp) (Hd_val (bp)) /* Also an l-value. */ +#define Hd_hp(hp) (* ((header_t *) (hp))) /* Also an l-value. */ +#define Hp_val(val) ((char *) (((header_t *) (val)) - 1)) +#define Hp_op(op) (Hp_val (op)) +#define Hp_bp(bp) (Hp_val (bp)) +#define Val_op(op) ((value) (op)) +#define Val_hp(hp) ((value) (((header_t *) (hp)) + 1)) +#define Op_hp(hp) ((value *) Val_hp (hp)) +#define Bp_hp(hp) ((char *) Val_hp (hp)) + +#define Num_tags (1 << 8) +#ifdef SIXTYFOUR +#define Max_wosize ((1L << 54) - 1) +#else +#define Max_wosize ((1 << 22) - 1) +#endif + +#define Wosize_val(val) (Wosize_hd (Hd_val (val))) +#define Wosize_op(op) (Wosize_val (op)) +#define Wosize_bp(bp) (Wosize_val (bp)) +#define Wosize_hp(hp) (Wosize_hd (Hd_hp (hp))) +#define Whsize_wosize(sz) ((sz) + 1) +#define Wosize_whsize(sz) ((sz) - 1) +#define Wosize_bhsize(sz) ((sz) / sizeof (value) - 1) +#define Bsize_wsize(sz) ((sz) * sizeof (value)) +#define Wsize_bsize(sz) ((sz) / sizeof (value)) +#define Bhsize_wosize(sz) (Bsize_wsize (Whsize_wosize (sz))) +#define Bhsize_bosize(sz) ((sz) + sizeof (header_t)) +#define Bosize_val(val) (Bsize_wsize (Wosize_val (val))) +#define Bosize_op(op) (Bosize_val (Val_op (op))) +#define Bosize_bp(bp) (Bosize_val (Val_bp (bp))) +#define Bosize_hd(hd) (Bsize_wsize (Wosize_hd (hd))) +#define Whsize_hp(hp) (Whsize_wosize (Wosize_hp (hp))) +#define Whsize_val(val) (Whsize_hp (Hp_val (val))) +#define Whsize_bp(bp) (Whsize_val (Val_bp (bp))) +#define Whsize_hd(hd) (Whsize_wosize (Wosize_hd (hd))) +#define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp))) +#define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd))) + +#ifdef BIG_ENDIAN +#define Tag_val(val) (((unsigned char *) (val)) [-1]) + /* Also an l-value. */ +#define Tag_hp(hp) (((unsigned char *) (hp)) [sizeof(value)-1]) + /* Also an l-value. */ +#else +#define Tag_val(val) (((unsigned char *) (val)) [-sizeof(value)]) + /* Also an l-value. */ +#define Tag_hp(hp) (((unsigned char *) (hp)) [0]) + /* Also an l-value. */ +#endif + +/* The Lowest tag for blocks containing no value. */ +#define No_scan_tag (Num_tags - 4) + + +/* 1- If tag < No_scan_tag : a tuple of fields. */ + +/* Pointer to the first field. */ +#define Op_val(x) ((value *) (x)) +/* Fields are numbered from 0. */ +#define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */ + +typedef int32 opcode_t; +typedef opcode_t * code_t; + +#define Closure_wosize 2 +#define Closure_tag (No_scan_tag - 1) +#define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */ +#define Env_val(val) (Field(val, 1)) /* Also an l-value. */ + + +/* 2- If tag >= No_scan_tag : a sequence of bytes. */ + +/* Pointer to the first byte */ +#define Bp_val(v) ((char *) (v)) +#define Val_bp(p) ((value) (p)) +/* Bytes are numbered from 0. */ +#define Byte(x, i) (((char *) (x)) [i]) /* Also an l-value. */ +#define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */ + +/* Abstract things. Their contents is not traced by the GC; therefore they + must not contain any [value]. +*/ +#define Abstract_tag No_scan_tag + +/* Strings. */ +#define String_tag (No_scan_tag + 1) +#define String_val(x) ((char *) Bp_val(x)) + +/* Floating-point numbers. */ +#define Double_tag (No_scan_tag + 2) +#define Double_wosize ((sizeof(double) / sizeof(value))) +#ifndef ALIGN_DOUBLE +#define Double_val(v) (* (double *) (v)) +#define Store_double_val(v,d) (* (double *) (v) = (d)) +#else +double Double_val P((value)); +void Store_double_val P((value,double)); +#endif + +/* Finalized things. Just like abstract things, but the GC will call the + [Final_fun] before deallocation. +*/ +#define Final_tag (No_scan_tag + 3) +typedef void (*final_fun) P((value)); +#define Final_fun(val) (((final_fun *) (val)) [0]) /* Also an l-value. */ + + +/* 3- Atoms are 0-tuples. They are statically allocated once and for all. */ + +extern header_t first_atoms[]; +#define Atom(tag) (Val_hp (&(first_atoms [tag]))) +#define Is_atom(v) (v >= Atom(0) && v <= Atom(255)) + +/* Booleans are atoms tagged 0 or 1 */ + +#define Val_bool(x) Atom((x) != 0) +#define Bool_val(x) Tag_val(x) +#define Val_false Atom(0) +#define Val_true Atom(1) + +/* The unit value is the atom tagged 0 */ + +#define Val_unit Atom(0) + +/* The table of global identifiers */ + +extern value global_data; + + +#endif /* _mlvalues_ */ diff --git a/byterun/oldlexing.c b/byterun/oldlexing.c new file mode 100644 index 0000000000..3d5d4a0903 --- /dev/null +++ b/byterun/oldlexing.c @@ -0,0 +1,36 @@ +/* The "get_next_char" routine for lexers generated by camllex. */ + +#include "interp.h" +#include "mlvalues.h" +#include "stacks.h" +#include "str.h" + +struct lexer_buffer { + value refill_buff; + value lex_buffer; + value lex_abs_pos; + value lex_start_pos; + value lex_curr_pos; + value lex_last_pos; + value lex_last_action; +}; + +value get_next_char(lexbuf) /* ML */ + struct lexer_buffer * lexbuf; +{ + mlsize_t buffer_len, curr_pos; + + buffer_len = string_length(lexbuf->lex_buffer); + curr_pos = Long_val(lexbuf->lex_curr_pos); + if (curr_pos >= buffer_len) { + Push_roots (r, 1); + r[0] = (value) lexbuf; + callback(lexbuf->refill_buff, (value) lexbuf); + lexbuf = (struct lexer_buffer *) r[0]; + curr_pos = Long_val(lexbuf->lex_curr_pos); + Pop_roots (); + } + lexbuf->lex_curr_pos += 2; + return Val_int(Byte_u(lexbuf->lex_buffer, curr_pos)); +} + diff --git a/byterun/parsing.c b/byterun/parsing.c new file mode 100644 index 0000000000..f051ffed7b --- /dev/null +++ b/byterun/parsing.c @@ -0,0 +1,205 @@ +/* The PDA automaton for parsers generated by camlyacc */ + +#include <stdio.h> +#include "config.h" +#include "mlvalues.h" +#include "memory.h" +#include "alloc.h" + +struct parser_tables { /* Mirrors parse_tables in ../stdlib/parsing.mli */ + value actions; + value transl; + char * lhs; + char * len; + char * defred; + char * dgoto; + char * sindex; + char * rindex; + char * gindex; + value tablesize; + char * table; + char * check; +}; + +struct parser_env { /* Mirrors parser_env in ../stdlib/parsing.ml */ + value s_stack; + value v_stack; + value symb_start_stack; + value symb_end_stack; + value stacksize; + value curr_char; + value lval; + value symb_start; + value symb_end; + value asp; + value rule_len; + value rule_number; + value sp; + value state; +}; + +#ifdef BIG_ENDIAN +#define Short(tbl,n) \ + (*((unsigned char *)((tbl) + (n) * sizeof(short))) + \ + (*((schar *)((tbl) + (n) * sizeof(short) + 1)) << 8)) +#else +#define Short(tbl,n) (((short *)(tbl))[n]) +#endif + +#ifdef DEBUG +int parser_trace = 0; +#define Trace(act) if(parser_trace) act +#else +#define Trace(act) +#endif + +/* Input codes */ + +#define START 0 /* Mirrors parser_input in ../stdlib/parsing.ml */ +#define TOKEN_READ 1 +#define STACKS_GROWN_1 2 +#define STACKS_GROWN_2 3 +#define SEMANTIC_ACTION_COMPUTED 4 + +/* Output codes */ + +#define READ_TOKEN Atom(0) /* Mirrors parser_output in ../stdlib/parsing.ml */ +#define RAISE_PARSE_ERROR Atom(1) +#define GROW_STACKS_1 Atom(2) +#define GROW_STACKS_2 Atom(3) +#define COMPUTE_SEMANTIC_ACTION Atom(4) + +/* The pushdown automata */ + +value parse_engine(tables, env, cmd, arg) /* ML */ + struct parser_tables * tables; + struct parser_env * env; + value cmd; + value arg; +{ + int state; + mlsize_t sp; + int n, n1, n2, m, state1; + + switch(Tag_val(cmd)) { + + case START: + state = 0; + sp = Int_val(env->sp); + + loop: + Trace(printf("Loop %d\n", state)); + n = Short(tables->defred, state); + if (n != 0) goto reduce; + if (Int_val(env->curr_char) >= 0) goto testshift; + env->sp = Val_int(sp); + env->state = Val_int(state); + return READ_TOKEN; + /* The ML code calls the lexer and updates */ + /* symb_start and symb_end */ + case TOKEN_READ: + sp = Int_val(env->sp); + state = Int_val(env->state); + env->curr_char = Field(tables->transl, Tag_val(arg)); + switch (Wosize_val(arg)) { + case 0: + env->lval = Val_long(0); break; + case 1: + modify(&env->lval, Field(arg, 0)); break; + default: { + value tuple; + mlsize_t size, i; + Push_roots(r, 4); + r[0] = (value) tables; + r[1] = (value) env; + r[2] = cmd; + r[3] = arg; + size = Wosize_val(arg); + tuple = alloc_tuple(size); + tables = (struct parser_tables *) r[0]; + env = (struct parser_env *) r[1]; + cmd = r[2]; + arg = r[3]; + for (i = 0; i < size; i++) Field(tuple, i) = Field(arg, i); + modify(&env->lval, tuple); + Pop_roots(); + break; } + } + Trace(printf("Token %d (0x%lx)\n", Int_val(env->curr_char), env->lval)); + + testshift: + n1 = Short(tables->sindex, state); + n2 = n1 + Int_val(env->curr_char); + if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && + Short(tables->check, n2) == Int_val(env->curr_char)) goto shift; + n1 = Short(tables->rindex, state); + n2 = n1 + Int_val(env->curr_char); + if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && + Short(tables->check, n2) == Int_val(env->curr_char)) { + n = Short(tables->table, n2); + goto reduce; + } + env->sp = Val_int(sp); + env->state = Val_int(state); + return RAISE_PARSE_ERROR; + /* The ML code raises the Parse_error exn */ + shift: + state = Short(tables->table, n2); + Trace(printf("Shift %d\n", state)); + sp++; + if (sp < Long_val(env->stacksize)) goto push; + env->sp = Val_int(sp); + env->state = Val_int(state); + return GROW_STACKS_1; + /* The ML code resizes the stacks */ + case STACKS_GROWN_1: + sp = Int_val(env->sp); + state = Int_val(env->state); + push: + Field(env->s_stack, sp) = Val_int(state); + modify(&Field(env->v_stack, sp), env->lval); + Field(env->symb_start_stack, sp) = env->symb_start; + Field(env->symb_end_stack, sp) = env->symb_end; + env->curr_char = Val_int(-1); + goto loop; + + reduce: + Trace(printf("Reduce %d\n", n)); + m = Short(tables->len, n); + env->asp = Val_int(sp); + env->rule_number = Val_int(n); + env->rule_len = Val_int(m); + sp = sp - m + 1; + m = Short(tables->lhs, n); + state1 = Int_val(Field(env->s_stack, sp - 1)); + n1 = Short(tables->gindex, m); + n2 = n1 + state1; + if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && + Short(tables->check, n2) == state1) { + state = Short(tables->table, n2); + } else { + state = Short(tables->dgoto, m); + } + if (sp < Long_val(env->stacksize)) goto semantic_action; + env->sp = Val_int(sp); + env->state = Val_int(state); + return GROW_STACKS_2; + /* The ML code resizes the stacks */ + case STACKS_GROWN_2: + sp = Int_val(env->sp); + state = Int_val(env->state); + semantic_action: + env->sp = Val_int(sp); + env->state = Val_int(state); + return COMPUTE_SEMANTIC_ACTION; + /* The ML code calls the semantic action */ + case SEMANTIC_ACTION_COMPUTED: + sp = Int_val(env->sp); + state = Int_val(env->state); + Field(env->s_stack, sp) = Val_int(state); + modify(&Field(env->v_stack, sp), arg); + Field(env->symb_end_stack, sp) = + Field(env->symb_end_stack, Int_val(env->asp)); + goto loop; + } +} diff --git a/byterun/prims.h b/byterun/prims.h new file mode 100644 index 0000000000..78478ce7a5 --- /dev/null +++ b/byterun/prims.h @@ -0,0 +1,11 @@ +/* Interface with C primitives. */ + +#ifndef _prims_ +#define _prims_ + +typedef value (*c_primitive)(); + +extern c_primitive cprim[]; +extern char * names_of_cprim[]; + +#endif /* _prims_ */ diff --git a/byterun/reverse.h b/byterun/reverse.h new file mode 100644 index 0000000000..74e5ccbc28 --- /dev/null +++ b/byterun/reverse.h @@ -0,0 +1,54 @@ +/* Swap byte-order in 16-bit, 32-bit and 64-bit words */ + +#ifndef _reverse_ +#define _reverse_ + + +#define Reverse_short(s) { \ + char * _p; \ + int _a; \ + _p = (char *) (s); \ + _a = _p[0]; \ + _p[0] = _p[1]; \ + _p[1] = _a; \ +} + +#define Reverse_int32(w) { \ + char * _p; \ + int _a; \ + _p = (char *) (w); \ + _a = _p[0]; \ + _p[0] = _p[3]; \ + _p[3] = _a; \ + _a = _p[1]; \ + _p[1] = _p[2]; \ + _p[2] = _a; \ +} + +#define Reverse_int64(d) { \ + char * _p; \ + int _a; \ + _p = (char *) (d); \ + _a = _p[0]; \ + _p[0] = _p[7]; \ + _p[7] = _a; \ + _a = _p[1]; \ + _p[1] = _p[6]; \ + _p[6] = _a; \ + _a = _p[2]; \ + _p[2] = _p[5]; \ + _p[5] = _a; \ + _a = _p[3]; \ + _p[3] = _p[4]; \ + _p[4] = _a; \ +} + +#ifdef SIXTYFOUR +#define Reverse_word Reverse_int64 +#else +#define Reverse_word Reverse_int32 +#endif + +#define Reverse_double Reverse_int64 + +#endif /* _reverse_ */ diff --git a/byterun/roots.c b/byterun/roots.c new file mode 100644 index 0000000000..eb0f5dfd0f --- /dev/null +++ b/byterun/roots.c @@ -0,0 +1,49 @@ +/* To walk the memory roots for garbage collection */ + +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "roots.h" +#include "stacks.h" + +value * local_roots = NULL; + +struct global_root { + value * root; + struct global_root * next; +}; + +static struct global_root * global_roots = NULL; + +void scan_local_roots (copy_fn) + void (*copy_fn) (); +{ + register value * sp; + value * block; + struct global_root * gr; + + /* The stack */ + for (sp = extern_sp; sp < stack_high; sp++) { + copy_fn (sp, *sp); + } + /* Local C roots */ + for (block = local_roots; block != NULL; block = (value *) block [1]){ + for (sp = block - (long) block [0]; sp < block; sp++){ + copy_fn (sp, *sp); + } + } + /* Global C roots */ + for (gr = global_roots; gr != NULL; gr = gr->next) { + copy_fn(gr->root, *(gr->root)); + } +} + +void register_global_root(r) + value * r; +{ + struct global_root * gr; + gr = (struct global_root *) stat_alloc(sizeof(struct global_root)); + gr->root = r; + gr->next = global_roots; + global_roots = gr; +} diff --git a/byterun/roots.h b/byterun/roots.h new file mode 100644 index 0000000000..67732f3cb0 --- /dev/null +++ b/byterun/roots.h @@ -0,0 +1,9 @@ +#ifndef _roots_ +#define _roots_ + +#include "misc.h" + +void scan_local_roots P((void (*copy_fn) (value *, value))); + + +#endif /* _roots_ */ diff --git a/byterun/signals.c b/byterun/signals.c new file mode 100644 index 0000000000..62aabd84cc --- /dev/null +++ b/byterun/signals.c @@ -0,0 +1,158 @@ +#include <signal.h> +#include "alloc.h" +#include "config.h" +#include "fail.h" +#include "interp.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "roots.h" +#include "signals.h" + +static Volatile int async_signal_mode = 0; +Volatile int pending_signal = 0; +value signal_handlers = 0; + +static void execute_signal(signal_number) + int signal_number; +{ + Assert (!async_signal_mode); + callback(Field(signal_handlers, signal_number), Val_int(signal_number)); +} + +void handle_signal(signal_number) + int signal_number; +{ +#ifndef BSD_SIGNALS + signal(signal_number, handle_signal); +#endif + if (async_signal_mode){ + leave_blocking_section (); + execute_signal(signal_number); + enter_blocking_section (); + }else{ + pending_signal = signal_number; + something_to_do = 1; + } +} + +void enter_blocking_section() +{ + int temp; + + while (1){ + Assert (!async_signal_mode); + /* If a signal arrives between the next two instructions, + it will be lost. */ + temp = pending_signal; pending_signal = 0; + if (temp) execute_signal(temp); + async_signal_mode = 1; + if (!pending_signal) break; + async_signal_mode = 0; + } +} + +/* This function may be called from outside a blocking section. */ +void leave_blocking_section() +{ + async_signal_mode = 0; +} + +#ifndef SIGABRT +#define SIGABRT 0 +#endif +#ifndef SIGALRM +#define SIGALRM 0 +#endif +#ifndef SIGFPE +#define SIGFPE 0 +#endif +#ifndef SIGHUP +#define SIGHUP 0 +#endif +#ifndef SIGILL +#define SIGILL 0 +#endif +#ifndef SIGINT +#define SIGINT 0 +#endif +#ifndef SIGKILL +#define SIGKILL 0 +#endif +#ifndef SIGPIPE +#define SIGPIPE 0 +#endif +#ifndef SIGQUIT +#define SIGQUIT 0 +#endif +#ifndef SIGSEGV +#define SIGSEGV 0 +#endif +#ifndef SIGTERM +#define SIGTERM 0 +#endif +#ifndef SIGUSR1 +#define SIGUSR1 0 +#endif +#ifndef SIGUSR2 +#define SIGUSR2 0 +#endif +#ifndef SIGCHLD +#define SIGCHLD 0 +#endif +#ifndef SIGCONT +#define SIGCONT 0 +#endif +#ifndef SIGSTOP +#define SIGSTOP 0 +#endif +#ifndef SIGTSTP +#define SIGTSTP 0 +#endif +#ifndef SIGTTIN +#define SIGTTIN 0 +#endif +#ifndef SIGTTOU +#define SIGTTOU 0 +#endif + +static int posix_signals[] = { + SIGABRT, SIGALRM, SIGFPE, SIGHUP, SIGILL, SIGINT, SIGKILL, SIGPIPE, + SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT, + SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU +}; + +value install_signal_handler(signal_number, action) /* ML */ + value signal_number, action; +{ + int sig = Int_val(signal_number); + if (sig < 0) { + sig = posix_signals[-sig-1]; + if (sig == 0) invalid_argument("Sys.signal: unavailable signal"); + } + switch(Tag_val(action)) { + case 0: /* Signal_default */ + signal(sig, SIG_DFL); + break; + case 1: /* Signal_ignore */ + signal(sig, SIG_IGN); + break; + case 2: /* Signal_handle */ + if (signal_handlers == 0) { + int i; + Push_roots(r, 1); + r[0] = action; + signal_handlers = alloc_tuple(32); + action = r[0]; + Pop_roots(); + for (i = 0; i < 32; i++) Field(signal_handlers, i) = Val_int(0); + register_global_root(&signal_handlers); + } + modify(&Field(signal_handlers, sig), Field(action, 0)); + signal(sig, handle_signal); + break; + default: + Assert(0); + } + return Val_unit; +} diff --git a/byterun/signals.h b/byterun/signals.h new file mode 100644 index 0000000000..83fbb043cc --- /dev/null +++ b/byterun/signals.h @@ -0,0 +1,13 @@ +#ifndef _signals_ +#define _signals_ + +#include "misc.h" + +extern value signal_handlers; +extern Volatile int pending_signal; + +void enter_blocking_section P((void)); +void leave_blocking_section P((void)); + +#endif /* _signals_ */ + diff --git a/byterun/stacks.c b/byterun/stacks.c new file mode 100644 index 0000000000..c831538590 --- /dev/null +++ b/byterun/stacks.c @@ -0,0 +1,60 @@ +/* To initialize and resize the stacks */ + +#include <string.h> +#include "config.h" +#include "fail.h" +#include "misc.h" +#include "mlvalues.h" +#include "stacks.h" + +value * stack_low; +value * stack_high; +value * stack_threshold; +value * extern_sp; +value * trapsp; +value global_data; + +void init_stack() +{ + stack_low = (value *) stat_alloc(Stack_size); + stack_high = stack_low + Stack_size / sizeof (value); + stack_threshold = stack_low + Stack_threshold / sizeof (value); + extern_sp = stack_high; + trapsp = stack_high; +} + +void realloc_stack() +{ + asize_t size; + value * new_low, * new_high, * new_sp; + value * p; + + Assert(extern_sp >= stack_low); + size = stack_high - stack_low; + if (size >= Max_stack_size) + raise_out_of_memory(); + size *= 2; + gc_message ("Growing stack to %ld kB.\n", + (long) size * sizeof(value) / 1024); + new_low = (value *) stat_alloc(size * sizeof(value)); + new_high = new_low + size; + +#define shift(ptr) \ + ((char *) new_high - ((char *) stack_high - (char *) (ptr))) + + new_sp = (value *) shift(extern_sp); + bcopy((char *) extern_sp, + (char *) new_sp, + (stack_high - extern_sp) * sizeof(value)); + stat_free((char *) stack_low); + trapsp = (value *) shift(trapsp); + for (p = trapsp; p < new_high; p = Trap_link(p)) + Trap_link(p) = (value *) shift(Trap_link(p)); + stack_low = new_low; + stack_high = new_high; + stack_threshold = stack_low + Stack_threshold / sizeof (value); + extern_sp = new_sp; + +#undef shift +} + diff --git a/byterun/stacks.h b/byterun/stacks.h new file mode 100644 index 0000000000..aa68532f8c --- /dev/null +++ b/byterun/stacks.h @@ -0,0 +1,26 @@ +/* structure of the stacks */ + +#ifndef _stacks_ +#define _stacks_ + + +#include "misc.h" +#include "mlvalues.h" +#include "memory.h" + +extern value * stack_low; +extern value * stack_high; +extern value * stack_threshold; +extern value * extern_sp; +extern value * trapsp; + +#define Trap_pc(tp) (((code_t *)(tp))[0]) +#define Trap_link(tp) (((value **)(tp))[1]) + +void reset_roots P((void)); +void init_stack P((void)); +void realloc_stack P((void)); + + +#endif /* _stacks_ */ + diff --git a/byterun/str.c b/byterun/str.c new file mode 100644 index 0000000000..c5f5eedb2d --- /dev/null +++ b/byterun/str.c @@ -0,0 +1,81 @@ +/* Operations on strings */ + +#include <string.h> +#include "alloc.h" +#include "fail.h" +#include "mlvalues.h" +#include "misc.h" + +mlsize_t string_length(s) + value s; +{ + mlsize_t temp; + temp = Bosize_val(s) - 1; + Assert (Byte (s, temp - Byte (s, temp)) == 0); + return temp - Byte (s, temp); +} + +value ml_string_length(s) /* ML */ + value s; +{ + mlsize_t temp; + temp = Bosize_val(s) - 1; + Assert (Byte (s, temp - Byte (s, temp)) == 0); + return Val_long(temp - Byte (s, temp)); +} + +value create_string(len) /* ML */ + value len; +{ + mlsize_t size = Long_val(len); + if (size > Max_wosize * sizeof(value) - 2) invalid_argument("String.create"); + return alloc_string(size); +} + +value blit_string(argv, argc) /* ML */ + value * argv; + int argc; +{ + bcopy(&Byte(argv[0], Long_val(argv[1])), + &Byte(argv[2], Long_val(argv[3])), + Int_val(argv[4])); + return Atom(0); +} + +value fill_string(s, offset, len, init) /* ML */ + value s, offset, len, init; +{ + register char * p; + register mlsize_t n; + register char c; + + c = Long_val(init); + for(p = &Byte(s, Long_val(offset)), n = Long_val(len); + n > 0; n--, p++) + *p = c; + return Atom(0); +} + +static unsigned char printable_chars_ascii[] = /* 0x20-0x7E */ + "\000\000\000\000\377\377\377\377\377\377\377\377\377\377\377\177\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"; +static unsigned char printable_chars_iso[] = /* 0x20-0x7E 0xA1-0xFF */ + "\000\000\000\000\377\377\377\377\377\377\377\377\377\377\377\177\000\000\000\000\376\377\377\377\377\377\377\377\377\377\377\377"; + +value is_printable(chr) /* ML */ + value chr; +{ + int c; + static int iso_charset = -1; + unsigned char * printable_chars; + + if (iso_charset == -1) { + char * lc_ctype = (char *) getenv("LC_CTYPE"); + if (lc_ctype != 0 && strcmp(lc_ctype, "iso_8859_1") == 0) + iso_charset = 1; + else + iso_charset = 0; + } + printable_chars = iso_charset ? printable_chars_iso : printable_chars_ascii; + c = Int_val(chr); + return Val_bool(printable_chars[c >> 3] & (1 << (c & 7))); +} diff --git a/byterun/str.h b/byterun/str.h new file mode 100644 index 0000000000..6f6373e57f --- /dev/null +++ b/byterun/str.h @@ -0,0 +1,11 @@ +#ifndef _str_ +#define _str_ + + +#include "misc.h" +#include "mlvalues.h" + +mlsize_t string_length P((value)); + + +#endif /* _str_ */ diff --git a/byterun/sys.c b/byterun/sys.c new file mode 100644 index 0000000000..10f05e2568 --- /dev/null +++ b/byterun/sys.c @@ -0,0 +1,186 @@ +/* Basic system calls */ + +#include <errno.h> +#include <fcntl.h> +#include <signal.h> +#include <string.h> +#include <unistd.h> +#include "config.h" +#include "alloc.h" +#include "fail.h" +#include "instruct.h" +#include "mlvalues.h" +#include "signals.h" +#include "stacks.h" + +extern int errno; + +#ifdef HAS_STRERROR + +extern char * strerror(); + +char * error_message() +{ + return strerror(errno); +} + +#else + +extern int sys_nerr; +extern char * sys_errlist []; + +char * error_message() +{ + if (errno < 0 || errno >= sys_nerr) + return "unknown error"; + else + return sys_errlist[errno]; +} + +#endif /* HAS_STRERROR */ + +void sys_error(arg) + char * arg; +{ + char * err = error_message(); + int err_len = strlen(err); + int arg_len; + value str; + + if (arg == NULL) { + str = alloc_string(err_len); + bcopy(err, &Byte(str, 0), err_len); + } else { + arg_len = strlen(arg); + str = alloc_string(arg_len + 2 + err_len); + bcopy(arg, &Byte(str, 0), arg_len); + bcopy(": ", &Byte(str, arg_len), 2); + bcopy(err, &Byte(str, arg_len + 2), err_len); + } + raise_sys_error(str); +} + +void sys_exit(retcode) /* ML */ + value retcode; +{ + exit(Int_val(retcode)); +} + +#ifndef O_BINARY +#define O_BINARY 0 +#endif +#ifndef O_TEXT +#define O_TEXT 0 +#endif + +static int sys_open_flags[] = { + O_RDONLY, O_WRONLY, O_RDWR, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, + O_BINARY, O_TEXT +}; + +value sys_open(path, flags, perm) /* ML */ + value path, flags, perm; +{ + int ret; + ret = open(String_val(path), convert_flag_list(flags, sys_open_flags), + Int_val(perm)); + if (ret == -1) sys_error(String_val(path)); + return Val_long(ret); +} + +value sys_close(fd) /* ML */ + value fd; +{ + if (close(Int_val(fd)) != 0) sys_error(NULL); + return Atom(0); +} + +value sys_remove(name) /* ML */ + value name; +{ + int ret; + ret = unlink(String_val(name)); + if (ret != 0) sys_error(String_val(name)); + return Atom(0); +} + +value sys_rename(oldname, newname) /* ML */ + value oldname, newname; +{ + if (rename(String_val(oldname), String_val(newname)) != 0) + sys_error(String_val(oldname)); + return Atom(0); +} + +value sys_chdir(dirname) /* ML */ + value dirname; +{ + if (chdir(String_val(dirname)) != 0) sys_error(String_val(dirname)); + return Atom(0); +} + +extern char * getenv(); + +value sys_getenv(var) /* ML */ + value var; +{ + char * res; + + res = getenv(String_val(var)); + if (res == 0) raise_not_found(); + return copy_string(res); +} + +static char ** main_argv; + +value sys_get_argv(unit) /* ML */ + value unit; +{ + return copy_string_array(main_argv); +} + +void sys_init(argv) + char ** argv; +{ + main_argv = argv; +} + +value sys_system_command(command) /* ML */ + value command; +{ + int retcode = system(String_val(command)); + if (retcode == -1) sys_error(String_val(command)); + return Val_int(retcode); +} + +/* Search path function */ + +char * searchpath(name) + char * name; +{ + static char fullname[512]; + char * path; + char * p; + char * q; + + for (p = name; *p != 0; p++) { + if (*p == '/') return name; + } + path = getenv("PATH"); + if (path == 0) return 0; + while(1) { + p = fullname; + while (*path != 0 && *path != ':') { + *p++ = *path++; + } + if (p != fullname) *p++ = '/'; + q = name; + while (*q != 0) { + *p++ = *q++; + } + *p = 0; + if (access(fullname, 1) == 0) return fullname; + if (*path == 0) return 0; + path++; + } +} diff --git a/byterun/sys.h b/byterun/sys.h new file mode 100644 index 0000000000..1d4e3b7a2a --- /dev/null +++ b/byterun/sys.h @@ -0,0 +1,10 @@ +#ifndef _sys_ +#define _sys_ + +#include "misc.h" + +void sys_error P((char *)); +void sys_init P((char **)); +void sys_exit P((value)) Noreturn; + +#endif /* _sys_ */ diff --git a/byterun/terminfo.c b/byterun/terminfo.c new file mode 100644 index 0000000000..214984892f --- /dev/null +++ b/byterun/terminfo.c @@ -0,0 +1,126 @@ +/* Read and output terminal commands */ + +#include "config.h" +#include "alloc.h" +#include "fail.h" +#include "io.h" +#include "mlvalues.h" + +#ifdef HAS_TERMINFO + +#undef getch +#include <curses.h> +#include <term.h> + +value terminfo_setup(unit) /* ML */ + value unit; +{ + if (setupterm(NULL, 1, 1) != 1) failwith("Terminfo.setupterm"); + return Val_unit; +} + +value terminfo_getstr(capa) /* ML */ + value capa; +{ + char * res = (char *) tigetstr(String_val(capa)); + if (res == (char *)(-1)) raise_not_found(); + return copy_string(res); +} + +value terminfo_getnum(capa) /* ML */ + value capa; +{ + int res = tigetnum(String_val(capa)); + if (res == -2) raise_not_found(); + return Val_int(res); +} + +#else + +#ifdef HAS_TERMCAP + +#define _BSD /* For DEC OSF1 */ +#undef getch +#include <curses.h> + +value terminfo_setup(unit) + value unit; +{ + static buffer[1024]; + if (tgetent(buffer, getenv("TERM")) != 1) failwith("Terminfo.setupterm"); + return Val_unit; +} + +value terminfo_getstr(capa) + value capa; +{ + char buff[1024]; + char * p = buff; + if (tgetstr(String_val(capa), &p) == 0) raise_not_found(); + return copy_string(buff); +} + +value terminfo_getnum(capa) + value capa; +{ + int res = tgetnum(String_val(capa)); + if (res == -1) raise_not_found(); + return Val_int(res); +} + +#else + +value terminfo_setup(unit) + value unit; +{ + failwith("Terminfo.setupterm"); + return Val_unit; +} + +value terminfo_getstr(capa) + value capa; +{ + raise_not_found(); + return Val_unit; +} + +value terminfo_getnum(capa) + value capa; +{ + raise_not_found(); + return Val_unit; +} + +#endif +#endif + +#if defined HAS_TERMINFO || defined HAS_TERMCAP + +static struct channel * terminfo_putc_channel; + +static int terminfo_putc(c) + int c; +{ + putch(terminfo_putc_channel, c); + return c; +} + +value terminfo_puts(chan, str, count) /* ML */ + struct channel * chan; + value str, count; +{ + terminfo_putc_channel = chan; + tputs(String_val(str), Int_val(count), terminfo_putc); + return Val_unit; +} + +#else + +value terminfo_puts(chan, str, count) + struct channel * chan; + value str, count; +{ + invalid_argument("Terminfo.puts"); +} + +#endif |