Insn definitions for RV64

.github/scripts/test.sh

@@ -0,0 +1,19 @@
+#!/bin/bash
+runmats() {
+  echo make allxhelp "$@"
+  make -C ${MACH}/mats allxhelp "$@" 2>&1 | tee -a Make.out | grep '^matting '
+}
+
+# Split these out so that we get output every 10 minutes on Windows builds.
+runmats o=0
+runmats o=3
+runmats o=3 cp0=t
+runmats o=3 cp0=t eval=interpret
+
+if [ -f ${MACH}/mats/summary ]; then
+  cat ${MACH}/mats/summary
+  diff -q .github/scripts/summary ${MACH}/mats/summary
+  exit $?
+else
+  exit 1
+fi

c/random.c

@@ -22,12 +22,14 @@
 
 /* Representation is arecord with 6 `double` fields: */
 
-#define RANDSTATEX10(x) (((double*)&RECORDINSTIT(x, 0))[0])
-#define RANDSTATEX11(x) (((double*)&RECORDINSTIT(x, 0))[1])
-#define RANDSTATEX12(x) (((double*)&RECORDINSTIT(x, 0))[2])
-#define RANDSTATEX20(x) (((double*)&RECORDINSTIT(x, 0))[3])
-#define RANDSTATEX21(x) (((double*)&RECORDINSTIT(x, 0))[4])
-#define RANDSTATEX22(x) (((double*)&RECORDINSTIT(x, 0))[5])
+#define RECORDINSTDBLA(x) ((double *)((uptr)&RECORDINSTIT(x, 0) + (max_float_alignment - ptr_bytes)))
+
+#define RANDSTATEX10(x) (RECORDINSTDBLA(x)[0])
+#define RANDSTATEX11(x) (RECORDINSTDBLA(x)[1])
+#define RANDSTATEX12(x) (RECORDINSTDBLA(x)[2])
+#define RANDSTATEX20(x) (RECORDINSTDBLA(x)[3])
+#define RANDSTATEX21(x) (RECORDINSTDBLA(x)[4])
+#define RANDSTATEX22(x) (RECORDINSTDBLA(x)[5])
 
 /* The Generator
    =============

c/schlib.c

@@ -216,6 +216,8 @@ void S_call_help(tc_in, singlep, lock_ts) ptr tc_in; IBOOL singlep; IBOOL lock_t
      the C stack and we may end up in a garbage collection */
     code = CP(tc);
     if (Sprocedurep(code)) code = CLOSCODE(code);
+    if (!IMMEDIATE(code) && !Scodep(code))
+      S_error_abort("S_call_help: invalid code pointer");
     S_immobilize_object(code);
 
     CP(tc) = AC1(tc);

c/vfasl.c

@@ -167,6 +167,7 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si);
 static uptr sweep(vfasl_info *vfi, ptr p);
 static int is_rtd(ptr tf, vfasl_info *vfi);
 
+static IFASLCODE abs_reloc_variant(IFASLCODE type);
 static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj);
 static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets, IBOOL to_static);
 static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offsets);
@@ -1083,6 +1084,20 @@ static int is_rtd(ptr tf, vfasl_info *vfi)
 #define VFASL_RELOC_TAG(p) (UNFIX(p) & ((1 << VFASL_RELOC_TAG_BITS) - 1))
 #define VFASL_RELOC_POS(p) (UNFIX(p) >> VFASL_RELOC_TAG_BITS)
 
+/* Picks a relocation variant that fits into the actual relocation's
+   shape, but holds an absolue value */
+static IFASLCODE abs_reloc_variant(IFASLCODE type) {
+  if (type == reloc_abs)
+    return reloc_abs;
+#if defined(I386) || defined(X86_64)
+  return reloc_abs;
+#elif defined(ARMV6)
+  return reloc_arm32_abs;
+#else
+  >> need to fill in for this platform <<
+#endif
+}
+
 static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj) {
   ptr pos;
   int which_singleton;
@@ -1142,7 +1157,7 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets
             code_off = RELOC_CODE_OFFSET(entry);
         }
         a += code_off;
-        obj = S_get_code_obj(reloc_abs, co, a, item_off);
+        obj = S_get_code_obj(abs_reloc_variant(RELOC_TYPE(entry)), co, a, item_off);
 
         if (IMMEDIATE(obj)) {
           if (Sfixnump(obj)) {

csug/foreign.stex

@@ -220,7 +220,10 @@ Windows: \scheme{__stdcall}, \scheme{__cdecl}, and \scheme{__com} (32-bit only).
 Since \scheme{__cdecl} is the default, specifying \scheme{__cdecl} is
 equivalent to specifying \scheme{#f} or no convention.
 Finally, \var{conv} can be \scheme{__collect_safe} to indicate that garbage
-collection is allowed concurrent to a call of the foreign procedure.
+collection is allowed concurrent to a call of the foreign procedure, or it
+can be \var{conv} can be \scheme{__varargs} to indicate that the procedure
+uses a convention that works with a variable number of arguments (which
+differs from the fixed-argument variant for some platforms and conventions).
 
 Use \scheme{__stdcall} to access most Windows API procedures.
 Use \scheme{__cdecl} for Windows API varargs procedures,

mats/fl.ms

@@ -26,6 +26,13 @@
         (flonum->fixnum (* (+ (ash (most-positive-fixnum) -1) 1) 1.0)))
    (eq? (most-negative-fixnum)
         (flonum->fixnum (* (most-negative-fixnum) 1.0)))
+   (eq? (+ (ash (most-positive-fixnum) -1) 1)
+        (flonum->fixnum (fl+ (* (+ (ash (most-positive-fixnum) -1) 1) 1.0) 0.5)))
+   (or (not (fixnum? (inexact->exact (exact->inexact (most-positive-fixnum)))))
+       (eq? (most-positive-fixnum)
+            (flonum->fixnum (fl+ (* (most-positive-fixnum) 1.0) 0.5))))
+   (eq? (most-negative-fixnum)
+        (flonum->fixnum (fl- (* (most-negative-fixnum) 1.0) 0.5)))
    (eq? (flonum->fixnum 0.0) 0)
    (eq? (flonum->fixnum 1.0) 1)
    (eq? (flonum->fixnum +4.5) +4)

mats/foreign.ms

@@ -1038,6 +1038,12 @@
     (define call-u64 (foreign-procedure "call_u64" (ptr unsigned-64 int int) unsigned-64))
     (define call-sf (foreign-procedure "call_sf" (ptr single-float int int) single-float))
     (define call-df (foreign-procedure "call_df" (ptr double-float int int) double-float))
+    (define call-varargs-df (foreign-procedure "call_varargs_df" (ptr double-float int int) double-float))
+    (define call-varargs-i7df (foreign-procedure "call_varargs_i7df" (ptr int
+                                                                          double-float double-float double-float
+                                                                          double-float double-float double-float
+                                                                          double-float)
+                                                 double-float))
     (define ($test-call-int signed? size call-int make-fc)
       (define n10000 (expt 256 size))
       (define nffff (- n10000 1))
@@ -1151,6 +1157,22 @@
         (double-float) double-float)
       73.25 7 23)
     108.25)
+  (equal?
+    (call-varargs-df
+      (foreign-callable
+        __varargs
+        (lambda (x y) (+ x y 5))
+        (double-float double-float) double-float)
+      10.25 20 300)
+    325.5)
+  (equal?
+    (call-varargs-i7df
+      (foreign-callable
+        __varargs
+        (lambda (i a b c d e f g) (+ i a b c d e f g 7))
+        (int double-float double-float double-float double-float double-float double-float double-float) double-float)
+      1 2.2 3.2 4.5 6.7 8.9 10.1 11.5)
+    55.1)
 
   (error?
     (call-i8
@@ -1212,6 +1234,13 @@
         (lambda (x) '(- x 7))
         (double-float) double-float)
       73.25 0 0))
+  (error?
+    (call-varargs-df
+      (foreign-callable
+        __varargs
+        (lambda (x y) '(- x 7))
+        (double-float double-float) double-float)
+      73.25 0 0))
 
   (begin
     (define u32xu32->u64
@@ -2540,9 +2569,33 @@
      (with-object-kept-live
       handler
       (call_many_times (foreign-callable-entry-point handler)))
+     (unlock-object handler)
      v)
    14995143)
 
+  (equal?
+   (let ()
+     (define v 0)
+     (define call_many_times_bv (foreign-procedure "call_many_times_bv" (void*) void))
+     (define work
+       (lambda (bv)
+         (set! v (+ v (bytevector-u8-ref bv 0)))
+         ;; Varying work, as above:
+         (let loop ([n (bitwise-and (bytevector-u8-ref bv 1) #xFFFF)])
+           (unless (zero? n)
+             (set! v (add1 v))
+             (loop (bitwise-arithmetic-shift-right n 1))))))
+     (define handlers (list (foreign-callable work (u8*) void)
+                            (foreign-callable work (u16*) void)
+                            (foreign-callable work (u32*) void)))
+     (map lock-object handlers)
+     (for-each (lambda (handler)
+                 (call_many_times_bv (foreign-callable-entry-point handler)))
+               handlers)
+     (map unlock-object handlers)
+     v)
+   103500000)
+
   ;; regression test related to saving registers that hold allocated
   ;; callable argument
   (let* ([call-with-many-args (foreign-procedure "call_with_many_args" (void*) boolean)]
@@ -2687,7 +2740,7 @@
       (separate-eval
         `(begin
            ,load-libc
-           (define f (foreign-procedure "printf" (string double) int))
+           (define f (foreign-procedure __varargs "printf" (string double) int))
            (f "(%g)" 3.5)
            (void)))
       read)
@@ -2697,7 +2750,7 @@
       (separate-eval
         `(begin
            ,load-libc
-           (define f (foreign-procedure "printf" (string double double double double double double) int))
+           (define f (foreign-procedure __varargs "printf" (string double double double double double double) int))
            (f "(%g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5)
            (void)))
       read)
@@ -2707,7 +2760,7 @@
       (separate-eval
         `(begin
            ,load-libc
-           (define f (foreign-procedure "printf" (string double double double double double double double double) int))
+           (define f (foreign-procedure __varargs "printf" (string double double double double double double double double) int))
            (f "(%g %g %g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5)
            (void)))
       read)
@@ -2717,11 +2770,30 @@
       (separate-eval
         `(begin
            ,load-libc
-           (define f (foreign-procedure "printf" (string double double double double double double double double double double) int))
+           (define f (foreign-procedure __varargs "printf" (string double double double double double double double double double double) int))
            (f "(%g %g %g %g %g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5)
            (void)))
       read)
     '(3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5))
+
+  (equal? (let ([cb (foreign-callable __varargs
+                                      (lambda (x y) (+ x y 5))
+                                      (double-float double-float) double-float)])
+            (with-object-kept-live
+             cb
+             ((foreign-procedure __varargs (foreign-callable-entry-point cb)
+                                 (double-float double-float) double-float)
+              3.4 5.5)))
+          13.9)
+  (equal? (let ([cb (foreign-callable __varargs
+                                      (lambda (x y) (+ x y 5))
+                                      (double-float double-float) single-float)])
+            (with-object-kept-live
+             cb
+             ((foreign-procedure __varargs (foreign-callable-entry-point cb)
+                                 (double-float double-float) single-float)
+              3.5 -5.25)))
+          3.25)
 )
 
 (mat structs

mats/foreign2.c

@@ -244,6 +244,17 @@ EXPORT double_float call_df(ptr code, double_float x, int m, int k) {
   return (*((double_float (*) (double_float))Sforeign_callable_entry_point(code)))(x + m) + k;
 }
 
+EXPORT double_float call_varargs_df(ptr code, double_float x, int m, int k) {
+  return (*((double_float (*) (double, ...))Sforeign_callable_entry_point(code)))(x - m, x + m) + k;
+}
+
+EXPORT double_float call_varargs_i7df(ptr code, int i,
+                                      double_float a, double_float b, double_float c,
+                                      double_float d, double_float e, double_float f,
+                                      double_float g) {
+  return (*((double_float (*) (int, ...))Sforeign_callable_entry_point(code)))(i, a, b, c, d, e, f, g);
+}
+
 EXPORT u8 *u8_star_to_u8_star(u8 *s) {
   return s == (u8 *)0 ? (u8 *)0 : s + 1;
 }
@@ -444,6 +455,18 @@ EXPORT void call_many_times(void (*f)(iptr))
   }
 }
 
+EXPORT void call_many_times_bv(void (*f)(char *s))
+{
+  /* make this sensible as u8*, u16*, and u32* */
+  char buf[8] = { 1, 2, 3, 4, 0, 0, 0, 0 };
+  int x;
+
+  for (x = 0; x < 1000000; x++) {
+    buf[0] = (x & 63) + 1;
+    f(buf);
+  }
+}
+
 typedef void (*many_arg_callback_t)(int i, const char* s1, const char* s2, const char* s3,
                                     const char* s4, int i2, const char* s6, const char* s7, int i3);
 EXPORT void call_with_many_args(many_arg_callback_t callback)

mats/hash.ms

@@ -1674,7 +1674,10 @@
           [wht (make-weak-eq-hashtable)]
           [eht (make-ephemeron-eq-hashtable)])
       (let ([ls2 (map (lambda (a1) (eq-hashtable-cell ht (car a1) (cdr a1))) ls1)]
-            [ls2-2 (map (lambda (a1) (eq-hashtable-try-atomic-cell ht (car a1) (cdr a1))) ls1)]
+            [ls2-2 (map (lambda (a1) (let loop ()
+                                       (define c (eq-hashtable-try-atomic-cell ht (car a1) (cdr a1)))
+                                       (or c (loop))))
+                        ls1)]
             [ls3 (map (lambda (a1) (hashtable-cell wht (car a1) (cdr a1))) ls1)]
             [ls4 (map (lambda (a1) (hashtable-cell eht (car a1) (cdr a1))) ls1)])
         (let ([ls2* (map (lambda (a1) (eq-hashtable-ref-cell ht (car a1))) ls1)]

mats/misc.ms

@@ -4694,34 +4694,35 @@
              (#2%display 1))))
 )
 
-(mat $read-time-stamp-counter
+(unless (memq (machine-type) '(arm32le tarm32le)) ; timestamp counter tends to be priviledged on arm32le
+  (mat $read-time-stamp-counter
 
-  (let ([t (#%$read-time-stamp-counter)])
-    (and (integer? t) (exact? t)))
+    (let ([t (#%$read-time-stamp-counter)])
+      (and (integer? t) (exact? t)))
 
-  (let ()
-    ;; NB: pulled from thread.ms, to use as a delay
-    (define fat+
-      (lambda (x y)
-        (if (zero? y)
-            x
-            (fat+ (1+ x) (1- y)))))
-    (define fatfib
-      (lambda (x)
-        (if (< x 2)
-            1
-            (fat+ (fatfib (1- x)) (fatfib (1- (1- x)))))))
-    (let loop ([count 10] [success 0])
-      (if (fx= count 0)
-          (>= success 9)
-          (let ([t0 (#%$read-time-stamp-counter)])
-            (fatfib 26)
-            (let ([t1 (#%$read-time-stamp-counter)])
-              (loop (fx- count 1)
-                    (if (< t0 t1)
-                        (fx+ success 1)
-                        success)))))))
-)
+    (let ()
+      ;; NB: pulled from thread.ms, to use as a delay
+      (define fat+
+        (lambda (x y)
+          (if (zero? y)
+              x
+              (fat+ (1+ x) (1- y)))))
+      (define fatfib
+        (lambda (x)
+          (if (< x 2)
+              1
+              (fat+ (fatfib (1- x)) (fatfib (1- (1- x)))))))
+      (let loop ([count 10] [success 0])
+        (if (fx= count 0)
+            (>= success 9)
+            (let ([t0 (#%$read-time-stamp-counter)])
+              (fatfib 26)
+              (let ([t1 (#%$read-time-stamp-counter)])
+                (loop (fx- count 1)
+                      (if (< t0 t1)
+                          (fx+ success 1)
+                          success)))))))
+    ))
 
 (mat procedure-arity-mask
   (equal? (procedure-arity-mask (lambda () #f)) 1)

mats/root-experr-compile-0-f-f-f

@@ -9950,6 +9950,7 @@ foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid
 foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
 foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
 foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
+foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
 foreign.mo:Expected error in mat foreign-C-types: "int-to-int: invalid foreign-procedure argument qqq".
 foreign.mo:Expected error in mat foreign-C-types: "unsigned-to-unsigned: invalid foreign-procedure argument qqq".
 foreign.mo:Expected error in mat foreign-C-types: "unsigned-int-to-unsigned-int: invalid foreign-procedure argument qqq".

mats/thread.ms

@@ -1569,6 +1569,18 @@
         (condition-broadcast c))
       (equal? gc-ids (list (get-thread-id)))))
 )
-
+
+(mat wait-for-threads
+  (begin
+    ;; To avoid breaking later tests that use `(collect)`,
+    ;; wait for any threads created here to exit
+    (let ()
+      (define $threads (foreign-procedure "(cs)threads" () scheme-object))
+      (let loop ()
+        (unless (= 1 (length ($threads)))
+          (sleep (make-time 'time-duration 10000 0))
+          (loop))))
+    #t)
+)  
 
 )