diff options
Diffstat (limited to 'byterun')
57 files changed, 0 insertions, 6537 deletions
diff --git a/byterun/.depend b/byterun/.depend deleted file mode 100644 index d43a9d1d88..0000000000 --- a/byterun/.depend +++ /dev/null @@ -1,121 +0,0 @@ -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 deleted file mode 100644 index 77266273b8..0000000000 --- a/byterun/Makefile +++ /dev/null @@ -1,80 +0,0 @@ -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 - -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) - -install: - cp camlrun $(BINDIR)/cslrun - rm -f $(LIBDIR)/libcamlrun.a - ar rc $(LIBDIR)/libcamlrun.a $(OBJS) - cd $(LIBDIR); $(RANLIB) libcamlrun.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 deleted file mode 100644 index afe0892cee..0000000000 --- a/byterun/alloc.c +++ /dev/null @@ -1,131 +0,0 @@ -/* 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 deleted file mode 100644 index 5b0a1029a0..0000000000 --- a/byterun/alloc.h +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 304cc545e6..0000000000 --- a/byterun/array.c +++ /dev/null @@ -1,62 +0,0 @@ -/* Operations on arrays */ - -#include "alloc.h" -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" - -value array_get(array, index) /* ML */ - value array, index; -{ - long idx = Long_val(index); - if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.get"); - return Field(array, idx); -} - -value array_set(array, index, newval) /* ML */ - value array, index, newval; -{ - long idx = Long_val(index); - if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.set"); - Modify(&Field(array, idx), newval); - return Val_unit; -} - -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 deleted file mode 100644 index a42fe7664d..0000000000 --- a/byterun/compare.c +++ /dev/null @@ -1,110 +0,0 @@ -#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 deleted file mode 100644 index 7efa4ff821..0000000000 --- a/byterun/config.h +++ /dev/null @@ -1,129 +0,0 @@ -#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 - -/* Signed char type */ - -#if defined(__STDC__) || defined(SIGNED_CHAR_WORKS) -typedef signed char schar; -#else -typedef char schar; -#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 deleted file mode 100644 index 0e961b3493..0000000000 --- a/byterun/crc.c +++ /dev/null @@ -1,91 +0,0 @@ -/* 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 deleted file mode 100644 index 1590dc0a4a..0000000000 --- a/byterun/exec.h +++ /dev/null @@ -1,27 +0,0 @@ -/* 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 deleted file mode 100644 index ea05d35e76..0000000000 --- a/byterun/extern.c +++ /dev/null @@ -1,245 +0,0 @@ -/* 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 deleted file mode 100644 index 8f0b00e9db..0000000000 --- a/byterun/fail.c +++ /dev/null @@ -1,106 +0,0 @@ -/* 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; - -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 deleted file mode 100644 index 76a88b7eb2..0000000000 --- a/byterun/fail.h +++ /dev/null @@ -1,37 +0,0 @@ -#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 mlraise P((value bucket)) Noreturn; -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 deleted file mode 100644 index 9c24de180e..0000000000 --- a/byterun/fix_code.c +++ /dev/null @@ -1,66 +0,0 @@ -/* 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 deleted file mode 100644 index c754fad278..0000000000 --- a/byterun/fix_code.h +++ /dev/null @@ -1,15 +0,0 @@ -/* 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 deleted file mode 100644 index f5b4864737..0000000000 --- a/byterun/floats.c +++ /dev/null @@ -1,226 +0,0 @@ -#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 deleted file mode 100644 index 0b348fd205..0000000000 --- a/byterun/freelist.c +++ /dev/null @@ -1,234 +0,0 @@ -#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 deleted file mode 100644 index 1f1aef9a7f..0000000000 --- a/byterun/freelist.h +++ /dev/null @@ -1,16 +0,0 @@ -/* 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 deleted file mode 100644 index b772f2f28d..0000000000 --- a/byterun/gc.h +++ /dev/null @@ -1,42 +0,0 @@ -#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 deleted file mode 100644 index facd9f30f7..0000000000 --- a/byterun/gc_ctrl.c +++ /dev/null @@ -1,212 +0,0 @@ -#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 deleted file mode 100644 index 5a88a9ab61..0000000000 --- a/byterun/gc_ctrl.h +++ /dev/null @@ -1,17 +0,0 @@ -#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 deleted file mode 100644 index 944bfac985..0000000000 --- a/byterun/hash.c +++ /dev/null @@ -1,103 +0,0 @@ -/* 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 deleted file mode 100644 index 5e3133565f..0000000000 --- a/byterun/instrtrace.c +++ /dev/null @@ -1,52 +0,0 @@ -/* 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 deleted file mode 100644 index c47b39781c..0000000000 --- a/byterun/instrtrace.h +++ /dev/null @@ -1,16 +0,0 @@ -/* 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 deleted file mode 100644 index 43cb8dcdf0..0000000000 --- a/byterun/instruct.h +++ /dev/null @@ -1,33 +0,0 @@ -/* 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 deleted file mode 100644 index 4fb438b44a..0000000000 --- a/byterun/intern.c +++ /dev/null @@ -1,230 +0,0 @@ -/* 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 deleted file mode 100644 index f96dd10d57..0000000000 --- a/byterun/interp.c +++ /dev/null @@ -1,865 +0,0 @@ -/* 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] = Val_int(signal_number); - sp[1] = (value) pc; - sp[2] = env; - sp[3] = Val_long(extra_args); - 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 deleted file mode 100644 index e652331d8a..0000000000 --- a/byterun/interp.h +++ /dev/null @@ -1,14 +0,0 @@ -/* 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 deleted file mode 100644 index 7b1a26c414..0000000000 --- a/byterun/intext.h +++ /dev/null @@ -1,54 +0,0 @@ -/* 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 deleted file mode 100644 index 4a4f767225..0000000000 --- a/byterun/ints.c +++ /dev/null @@ -1,81 +0,0 @@ -#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 deleted file mode 100644 index 67bc961f78..0000000000 --- a/byterun/io.c +++ /dev/null @@ -1,393 +0,0 @@ -/* 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 deleted file mode 100644 index d679886cbc..0000000000 --- a/byterun/io.h +++ /dev/null @@ -1,52 +0,0 @@ -/* 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 deleted file mode 100644 index 9c7ee844b3..0000000000 --- a/byterun/main.c +++ /dev/null @@ -1,230 +0,0 @@ -/* 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 "fix_code.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 deleted file mode 100644 index 11dd32b790..0000000000 --- a/byterun/major_gc.c +++ /dev/null @@ -1,305 +0,0 @@ -#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 deleted file mode 100644 index 0c39a87de1..0000000000 --- a/byterun/major_gc.h +++ /dev/null @@ -1,42 +0,0 @@ -#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 deleted file mode 100644 index aacf05eba7..0000000000 --- a/byterun/memory.c +++ /dev/null @@ -1,205 +0,0 @@ -#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 deleted file mode 100644 index 5df199e02e..0000000000 --- a/byterun/memory.h +++ /dev/null @@ -1,88 +0,0 @@ -/* 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 deleted file mode 100644 index ce2bb15293..0000000000 --- a/byterun/meta.c +++ /dev/null @@ -1,94 +0,0 @@ -/* Primitives for the toplevel */ - -#include "alloc.h" -#include "fix_code.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 deleted file mode 100644 index f2fd8fbd31..0000000000 --- a/byterun/minor_gc.c +++ /dev/null @@ -1,156 +0,0 @@ -#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 deleted file mode 100644 index 112ba58a97..0000000000 --- a/byterun/minor_gc.h +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index c53452acd0..0000000000 --- a/byterun/misc.c +++ /dev/null @@ -1,166 +0,0 @@ -#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 deleted file mode 100644 index 14c7bb3385..0000000000 --- a/byterun/misc.h +++ /dev/null @@ -1,90 +0,0 @@ -/* 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 deleted file mode 100644 index f820f289a6..0000000000 --- a/byterun/mlvalues.h +++ /dev/null @@ -1,213 +0,0 @@ -#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 deleted file mode 100644 index 3d5d4a0903..0000000000 --- a/byterun/oldlexing.c +++ /dev/null @@ -1,36 +0,0 @@ -/* 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 deleted file mode 100644 index f051ffed7b..0000000000 --- a/byterun/parsing.c +++ /dev/null @@ -1,205 +0,0 @@ -/* 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 deleted file mode 100644 index 78478ce7a5..0000000000 --- a/byterun/prims.h +++ /dev/null @@ -1,11 +0,0 @@ -/* 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 deleted file mode 100644 index 74e5ccbc28..0000000000 --- a/byterun/reverse.h +++ /dev/null @@ -1,54 +0,0 @@ -/* 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 deleted file mode 100644 index eb0f5dfd0f..0000000000 --- a/byterun/roots.c +++ /dev/null @@ -1,49 +0,0 @@ -/* 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 deleted file mode 100644 index 67732f3cb0..0000000000 --- a/byterun/roots.h +++ /dev/null @@ -1,9 +0,0 @@ -#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 deleted file mode 100644 index a16a00c5a4..0000000000 --- a/byterun/signals.c +++ /dev/null @@ -1,158 +0,0 @@ -#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 - -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 deleted file mode 100644 index 83fbb043cc..0000000000 --- a/byterun/signals.h +++ /dev/null @@ -1,13 +0,0 @@ -#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 deleted file mode 100644 index c831538590..0000000000 --- a/byterun/stacks.c +++ /dev/null @@ -1,60 +0,0 @@ -/* 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 deleted file mode 100644 index aa68532f8c..0000000000 --- a/byterun/stacks.h +++ /dev/null @@ -1,26 +0,0 @@ -/* 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 deleted file mode 100644 index 68ced732fd..0000000000 --- a/byterun/str.c +++ /dev/null @@ -1,98 +0,0 @@ -/* 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 string_get(str, index) /* ML */ - value str, index; -{ - long idx = Long_val(index); - if (idx < 0 || idx >= string_length(str)) invalid_argument("String.get"); - return Val_int(Byte_u(str, idx)); -} - -value string_set(str, index, newval) /* ML */ - value str, index, newval; -{ - long idx = Long_val(index); - if (idx < 0 || idx >= string_length(str)) invalid_argument("String.set"); - Byte_u(str, idx) = Int_val(newval); - return Val_unit; -} - -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 deleted file mode 100644 index 6f6373e57f..0000000000 --- a/byterun/str.h +++ /dev/null @@ -1,11 +0,0 @@ -#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 deleted file mode 100644 index 61f1cad05a..0000000000 --- a/byterun/sys.c +++ /dev/null @@ -1,184 +0,0 @@ -/* Basic system calls */ - -#include <errno.h> -#include <fcntl.h> -#include <signal.h> -#include <stdlib.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_file_exists(name) /* ML */ - value name; -{ - return Val_bool(access(String_val(name), F_OK) == 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); -} - -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, F_OK) == 0) return fullname; - if (*path == 0) return 0; - path++; - } -} diff --git a/byterun/sys.h b/byterun/sys.h deleted file mode 100644 index 1d4e3b7a2a..0000000000 --- a/byterun/sys.h +++ /dev/null @@ -1,10 +0,0 @@ -#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 deleted file mode 100644 index 214984892f..0000000000 --- a/byterun/terminfo.c +++ /dev/null @@ -1,126 +0,0 @@ -/* 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 |