Final commit

.github/workflows/blank.yml

@@ -13,6 +13,7 @@ jobs:
       matrix:
         os:
           - ubuntu-latest
+          - macos-latest-xl
         ocaml-compiler:
           - 4.13.1
 
@@ -33,5 +34,3 @@ jobs:
       - run: eval $(opam env)
       - run: opam exec -- make
       - run: opam exec -- make regression-all
-      - run: opam exec -- make unit_tests
-      - run: opam exec -- make negative_scenarios_tests

Makefile

@@ -20,7 +20,7 @@ remake_runtime:
 	$(MAKE) -C runtime clean
 	$(MAKE) -C runtime all
 
-copy_to_build: all
+copy_to_build: all remake_runtime
 	mkdir -p $(BUILDDIR)
 	cp runtime/Std.i runtime/runtime.a stdlib/* $(BUILDDIR)
 

runtime/gc.c

@@ -59,8 +59,10 @@ void *alloc (size_t size) {
 #endif
   void *p = gc_alloc_on_existing_heap(size);
   if (!p) {
+    fprintf(stderr, "Garbage collection is not implemented yet.\n");
+    exit(149);
     // not enough place in the heap, need to perform GC cycle
-    p = gc_alloc(size);
+    // p = gc_alloc(size);
   }
   return p;
 }
@@ -223,7 +225,7 @@ void *gc_alloc (size_t size) {
 }
 
 static void gc_root_scan_stack () {
-  for (size_t *p = (size_t *)(__gc_stack_top + 4); p < (size_t *)__gc_stack_bottom; ++p) {
+  for (size_t *p = (size_t *)(__gc_stack_top + sizeof(size_t)); p < (size_t *)__gc_stack_bottom; ++p) {
     gc_test_and_mark_root((size_t **)p);
   }
 }
@@ -438,7 +440,7 @@ void update_references (memory_chunk *old_heap) {
     heap_next_obj_iterator(&it);
   }
   // fix pointers from stack
-  scan_and_fix_region(old_heap, (void *)__gc_stack_top + 4, (void *)__gc_stack_bottom + 4);
+  scan_and_fix_region(old_heap, (void *)__gc_stack_top + sizeof(size_t), (void *)__gc_stack_bottom + sizeof(size_t));
 
   // fix pointers from extra_roots
   scan_and_fix_region_roots(old_heap);
@@ -571,7 +573,7 @@ void __init (void) {
   srandom(time(NULL));
 
   heap.begin = mmap(
-      NULL, space_size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0);
+      NULL, space_size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
   if (heap.begin == MAP_FAILED) {
     perror("ERROR: __init: mmap failed\n");
     exit(1);
@@ -684,7 +686,7 @@ void set_forward_address (void *obj, size_t addr) {
 
 bool is_marked (void *obj) {
   data *d        = TO_DATA(obj);
-  int   mark_bit = GET_MARK_BIT(d->forward_address);
+  aint   mark_bit = GET_MARK_BIT(d->forward_address);
   return mark_bit;
 }
 

runtime/gc.h

@@ -41,7 +41,7 @@
 // #  define MINIMUM_HEAP_CAPACITY (8)
 // #else
 // #  define MINIMUM_HEAP_CAPACITY (1 << 2)
-#define MINIMUM_HEAP_CAPACITY (1 << 26)
+#define MINIMUM_HEAP_CAPACITY (1 << 30)
 // #endif
 
 #include <stdbool.h>

runtime/printf.s

@@ -1,10 +1,10 @@
 .section .text
 
 .global Lprintf
-.extern printf
+.extern Bprintf
 
 .global Lfprintf
-.extern fprintf
+.extern Bfprintf
 
 .global Lsprintf
 .extern Bsprintf
@@ -26,22 +26,22 @@ Lprintf:
         movq    %rsp, %rax
 # rdi --- format string
 # r11 --- number of arguments except format string 
-loop:
+Lprintf_loop:
         movq    $0, %r12
         cmpq    %r11, %r12
-        jz    continue
+        jz    Lprintf_continue
 
         decq    %r11
         movq    (%rax), %r10
         testq   $1, %r10
-        jz    jmpCont
+        jz    Lprintf_loop_end
 # unbox value
         sarq    %r10
         movq    %r10, (%rax)
-jmpCont:
+Lprintf_loop_end:
         addq    $8, %rax
-        jmp     loop
+        jmp     Lprintf_loop
-continue:
+Lprintf_continue:
         popq    %rsi
         popq    %rdx
         popq    %rcx
@@ -49,7 +49,7 @@ continue:
         popq    %r9
 # restore return address
         pushq   %r14
-        jmp     printf
+        jmp     Bprintf
 
 Lfprintf:
 # save return address
@@ -85,7 +85,7 @@ Lfprintf_continue:
         popq    %r9
 # restore return address
         pushq   %r14
-        jmp     fprintf
+        jmp     Bfprintf
 
 Lsprintf:
 # save return address

runtime/runtime.c

@@ -82,7 +82,7 @@ extern aint LcompareTags (void *p, void *q) {
   if (TAG(pd->data_header) == SEXP_TAG && TAG(qd->data_header) == SEXP_TAG) {
     return BOX((TO_SEXP(p)->tag) - (TO_SEXP(q)->tag));
   } else {
-    failure("not a sexpr in compareTags: %d, %d\n", TAG(pd->data_header), TAG(qd->data_header));
+    failure("not a sexpr in compareTags: %ld, %ld\n", TAG(pd->data_header), TAG(qd->data_header));
   }
   // dead code
   return 0;
@@ -319,7 +319,7 @@ static void printValue (void *p) {
   data *a = (data *)BOX(NULL);
   aint   i = BOX(0);
   if (UNBOXED(p)) {
-    printStringBuf("%d", UNBOX(p));
+    printStringBuf("%ld", UNBOX(p));
   } else {
     if (!is_valid_heap_pointer(p)) {
       printStringBuf("0x%x", p);
@@ -468,7 +468,7 @@ extern void *Lsubstring (void *subj, aint p, aint l) {
     return r->contents;
   }
 
-  failure("substring: index out of bounds (position=%d, length=%d, subject length=%d)",
+  failure("substring: index out of bounds (position=%ld, length=%ld, subject length=%ld)",
           pp,
           ll,
           LEN(d->data_header));
@@ -497,7 +497,7 @@ extern aint LregexpMatch (struct re_pattern_buffer *b, char *s, aint pos) {
 
   res = re_match(b, s, LEN(TO_DATA(s)->data_header), UNBOX(pos), 0);
 
-  /* printf ("regexpMatch %x: %s, res=%d\n", b, s+UNBOX(pos), res); */
+  /* printf ("regexpMatch %x: %s, res=%ld\n", b, s+UNBOX(pos), res); */
 
   if (res) { return BOX(res); }
 
@@ -537,7 +537,7 @@ void *Lclone (void *p) {
       res = (void *)obj->contents;
       break;
 
-    default: failure("invalid data_header %d in clone *****\n", t);
+    default: failure("invalid data_header %ld in clone *****\n", t);
   }
   pop_extra_root(&p);
 
@@ -587,7 +587,7 @@ aint inner_hash (aint depth, auint acc, void *p) {
         break;
       }
 
-      default: failure("invalid data_header %d in hash *****\n", t);
+      default: failure("invalid data_header %ld in hash *****\n", t);
     }
 
     for (; i < l; i++) acc = inner_hash(depth + 1, acc, ((void **)a->contents)[i]);
@@ -598,7 +598,7 @@ aint inner_hash (aint depth, auint acc, void *p) {
 
 extern void *LstringInt (char *b) {
   aint n;
-  sscanf(b, "%d", &n);
+  sscanf(b, "%ld", &n);
   return (void *)BOX(n);
 }
 
@@ -659,7 +659,7 @@ extern aint Lcompare (void *p, void *q) {
             break;
           }
 
-          default: failure("invalid data_header %d in compare *****\n", ta);
+          default: failure("invalid data_header %ld in compare *****\n", ta);
         }
 
         for (; i < la; i++) {
@@ -971,7 +971,7 @@ extern void *Bsta (void *v, aint i, void *x) {
 extern void Bmatch_failure (void *v, char *fname, aint line, aint col) {
   createStringBuf();
   printValue(v);
-  failure("match failure at %s:%d:%d, value '%s'\n",
+  failure("match failure at %s:%ld:%ld, value '%s'\n",
           fname,
           UNBOX(line),
           UNBOX(col),
@@ -1026,11 +1026,6 @@ extern void *LgetEnv (char *var) {
 
 extern aint Lsystem (char *cmd) { return BOX(system(cmd)); }
 
-extern void Lfailure (char *s, ...);
-extern void Lprintf (char *s, ...);
-extern void *Lsprintf (char *fmt, ...);
-extern void Lfprintf (FILE *f, char *s, ...);
-
 #ifndef X86_64
 // In X86_64 we are not able to modify va_arg
 
@@ -1106,6 +1101,7 @@ extern void Lfprintf (FILE *f, char *s, ...) {
 
     if (vfprintf(f, s, args) < 0) { failure("fprintf (...): %s\n", strerror(errno)); }
 }
+
 #else
 
 extern void *Bsprintf (char *fmt, ...) {
@@ -1133,6 +1129,29 @@ extern void *Bsprintf (char *fmt, ...) {
     return s;
 }
 
+extern void Bprintf (char *s, ...) {
+    va_list args;   // = (va_list)BOX(NULL);
+
+    ASSERT_STRING("printf:1", s);
+
+    va_start(args, s);
+
+    if (vprintf(s, args) < 0) { failure("fprintf (...): %s\n", strerror(errno)); }
+
+    fflush(stdout);
+}
+
+extern void Bfprintf (FILE *f, char *s, ...) {
+    va_list args;   // = (va_list)BOX(NULL);
+
+    ASSERT_BOXED("fprintf:1", f);
+    ASSERT_STRING("fprintf:2", s);
+
+    va_start(args, s);
+
+    if (vfprintf(f, s, args) < 0) { failure("fprintf (...): %s\n", strerror(errno)); }
+}
+
 #endif
 
 extern FILE *Lfopen (char *f, char *m) {
@@ -1261,7 +1280,7 @@ extern aint Lwrite (aint n) {
 extern aint Lrandom (aint n) {
   ASSERT_UNBOXED("Lrandom, 0", n);
 
-  if (UNBOX(n) <= 0) { failure("invalid range in random: %d\n", UNBOX(n)); }
+  if (UNBOX(n) <= 0) { failure("invalid range in random: %ld\n", UNBOX(n)); }
 
   return BOX(random() % UNBOX(n));
 }

src/X86.ml

@@ -387,6 +387,9 @@ let compile_call env ?fname nargs tail =
     let allowed_function =
       match fname with
       | Some "Lprintf" -> false
+      | Some "Lsprintf" -> false
+      | Some "Lfprintf" -> false
+      | Some "Lfailure" -> false
       | Some fname -> not (fname.[0] = '.')
       | None -> true
     in