Chez Scheme: larger range for relative return address

A 16-bit range is not large enough for "nanopass/pass.ss".

.makefile

@@ -338,7 +338,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
 RACKET_FOR_BUILD = $(RACKET)
 
 # This branch name changes each time the pb boot files are updated:
-PB_BRANCH == circa-7.9.0.9-1
+PB_BRANCH == circa-7.9.0.10-1
 PB_REPO = https://github.com/racket/pb
 
 # Alternative source for Chez Scheme boot files, normally set by
@@ -420,7 +420,6 @@ cs-minimal-in-place-after-base:
 cs-minimal-in-place-after-base-cross:
 	$(MAKE) plain-minimal-in-place-after-base PLAIN_RACKET="$(RACKET_FOR_BUILD)" PLT_SETUP_OPTIONS="--no-pkg-deps $(PLT_SETUP_OPTIONS)"
 
-
 fetch-pb:
 	if [ "$(EXTRA_REPOS_BASE)" = "" ] ; \
           then $(MAKE) fetch-pb-from ; \
@@ -442,12 +441,19 @@ fetch-pb-from:
 	  else cd $(PB_DIR) && git fetch -q origin $(PB_BRANCH):remotes/origin/$(PB_BRANCH) ; fi
 	cd $(PB_DIR) && git checkout -q $(PB_BRANCH)
 
+pb-fetch:
+	$(MAKE) fetch-pb
+
 # Helpers for managing the "pb" repo:
+#  * `make pb-build` to rebuild pb boot files
 #  * `make pb-stage` after updating `PB_BRANCH`
 #  * `make pb-push` to upload the branch after checking that
 #    the staged branch looks right
 # If you don't have push access to `PB_REPO`, you may need to
 # change the origin of your "pb" checkout.
+pb-build:
+	cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb
+
 pb-stage:
 	cd $(PB_DIR) && git branch $(PB_BRANCH)
 	cd $(PB_DIR) && git checkout $(PB_BRANCH)

Makefile

@@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
 RACKET =
 RACKET_FOR_BOOTFILES = $(RACKET)
 RACKET_FOR_BUILD = $(RACKET)
-PB_BRANCH = circa-7.9.0.9-1
+PB_BRANCH = circa-7.9.0.10-1
 PB_REPO = https://github.com/racket/pb
 EXTRA_REPOS_BASE =
 CS_CROSS_SUFFIX =
@@ -307,14 +307,18 @@ maybe-fetch-pb-as-is:
 	echo done
 fetch-pb-from:
 	mkdir -p racket/src/ChezScheme/boot
-	if [ ! -d racket/src/ChezScheme/boot/pb ] ; 	  then git clone -q -b circa-7.9.0.9-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; 	  else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.9-1:remotes/origin/circa-7.9.0.9-1 ; fi
+	if [ ! -d racket/src/ChezScheme/boot/pb ] ; 	  then git clone -q -b circa-7.9.0.10-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; 	  else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.10-1:remotes/origin/circa-7.9.0.10-1 ; fi
-	cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.9-1
+	cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.10-1
+pb-fetch:
+	$(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" PB_REPO="$(PB_REPO)"
+pb-build:
+	cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb
 pb-stage:
-	cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.9-1
+	cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.10-1
-	cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.9-1
+	cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.10-1
 	cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build"
 pb-push:
-	cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.9-1
+	cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.10-1
 win-cs-base:
 	IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)"
 	IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"

pkgs/base/info.rkt

@@ -14,7 +14,7 @@
 
 ;; In the Racket source repo, this version should change only when
 ;; "racket_version.h" changes:
-(define version "7.9.0.9")
+(define version "7.9.0.10")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

racket/src/ChezScheme/c/fasl.c

@@ -1925,14 +1925,21 @@ static void sparc64_set_literal(address, item) void *address; uptr item; {
 #endif /* SPARC64 */
 
 #ifdef PORTABLE_BYTECODE_BIGENDIAN
+typedef struct {
+  octet *code;
+  uptr size;
+} rpheader_t;
+static rpheader_t *rpheader_stack;
+static int rpheader_stack_size = 0, rpheader_stack_pos = 0;
+
 static void swap_code_endian(octet *code, uptr len)
 {
-  octet *next_rpheader = NULL;
-  uptr header_size = 0;
-
   while (len > 0) {
-    if (code == next_rpheader) {
+    if ((rpheader_stack_pos > 0)
+	&& (code == rpheader_stack[rpheader_stack_pos-1].code)) {
       /* swap 8-byte segments while we're in the header */
+      uptr header_size = rpheader_stack[--rpheader_stack_pos].size;
+
       while (header_size > 0) {
         octet a = code[0];
         octet b = code[1];
@@ -1966,28 +1973,62 @@ static void swap_code_endian(octet *code, uptr len)
       code[2] = b;
       code[3] = a;
 
+      code += 4;
+      len -= 4;
+
       if (a == pb_adr) {
         /* delta can be negative for a mvlet-error reinstall of the return address */
-        iptr delta = (int16_t)(uint16_t)(((uptr)d << 8) + c);
+        iptr delta = (((iptr)d << (ptr_bits - 8)) >> (ptr_bits - 20)) + ((iptr)c << 4) + (b >> 4);
         if (delta > 0) {
           /* after a few more instructions, we'll hit
              a header where 64-bit values needs to be
              swapped, instead of 32-bit values */
-          octet *after_rpheader = code + 4 + delta;
+          octet *after_rpheader = code + delta, *rpheader;
+	  uptr header_size;
+	  int pos;
+
+	  if ((uptr)delta > len)
+	    S_error_abort("swap endian: delta goes past end");
+	  if (delta & 0x3)
+	    S_error_abort("swap endian: delta is not a multiple of 4");
 
           if (after_rpheader[-8] & 0x1)
             header_size = size_rp_compact_header;
           else
             header_size = size_rp_header;
+          rpheader = after_rpheader - header_size;
 
-          next_rpheader = after_rpheader - header_size;
+	  if (rpheader_stack_pos == rpheader_stack_size) {
+	    int new_size = (2 * rpheader_stack_size) + 16;
+	    rpheader_t *new_stack;
+	    new_stack = malloc(new_size * sizeof(rpheader_t));
+	    if (rpheader_stack != NULL) {
+	      memcpy(new_stack, rpheader_stack, rpheader_stack_pos * sizeof(rpheader_t));
+	      free(rpheader_stack);
+	    }
+	    rpheader_stack_size = new_size;
+	    rpheader_stack = new_stack;
+	  }
+
+	  rpheader_stack[rpheader_stack_pos].code = rpheader;
+	  rpheader_stack[rpheader_stack_pos].size = header_size;
+	  rpheader_stack_pos++;
+
+	  /* bubble down to keep sorted */
+	  for (pos = rpheader_stack_pos - 2; pos > 0; --pos) {
+	    if (rpheader_stack[pos].code < rpheader_stack[pos+1].code) {
+	      rpheader_t tmp = rpheader_stack[pos];
+	      rpheader_stack[pos] = rpheader_stack[pos+1];
+	      rpheader_stack[pos+1] = tmp;
+	    }
+	  }
         }
       }
-
-      code += 4;
-      len -= 4;
     }
   }
+
+  if (rpheader_stack_pos > 0)
+    S_error_abort("swap endian: header stack ends non-empty");
 }
 
 void S_swap_dounderflow_header_endian(ptr co)

racket/src/ChezScheme/c/pb.c

@@ -17,6 +17,9 @@ typedef uint32_t instruction_t;
 #define INSTR_di_imm(instr)   (((int32_t)(instr)) >> 16)
 #define INSTR_di_imm_unsigned(instr) ((instr) >> 16)
 
+#define INSTR_adr_dest(instr) INSTR_di_dest(instr)
+#define INSTR_adr_imm(instr)  (((int32_t)(instr)) >> 12)
+
 #define INSTR_drr_dest(instr) INSTR_d_dest(instr)
 #define INSTR_drr_reg1(instr) (((instr) >> 12) & 0xF)
 #define INSTR_drr_reg2(instr) (((instr) >> 16) & 0xF)
@@ -673,7 +676,7 @@ void S_pb_interp(ptr tc, void *bytecode) {
     case pb_return:
       return; /* <--- not break */
     case pb_adr:
-      regs[INSTR_di_dest(instr)] = (uptr)TO_PTR(next_ip) + INSTR_di_imm(instr);
+      regs[INSTR_adr_dest(instr)] = (uptr)TO_PTR(next_ip) + INSTR_adr_imm(instr);
       break;
     case pb_interp:
       {

racket/src/ChezScheme/makefiles/Mf-boot.in

@@ -21,7 +21,7 @@ doit: $(bootfiles)
 
 %.boot:
 	rm -rf ../xc-$*
-	( cd .. ; "${srcdir}"/workarea $* xc-$* )
+	( cd .. ; "${srcdir}"/workarea $* xc-$* $(m) )
 	( cd ../xc-$*/s ; $(MAKE) -f Mf-cross base=../../$(workarea) m=$(m) xm=$* )
 	mkdir -p ../boot/$*
 	( cd ../xc-$*/s ; $(MAKE) keepbootfiles )

racket/src/ChezScheme/makefiles/Mf-install.in

@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.3.52
+Version=csv9.5.3.53
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot

racket/src/ChezScheme/s/cmacros.ss

@@ -357,7 +357,7 @@
 ;; ---------------------------------------------------------------------
 ;; Version and machine types:
 
-(define-constant scheme-version #x09050334)
+(define-constant scheme-version #x09050335)
 
 (define-syntax define-machine-types
   (lambda (x)
@@ -375,6 +375,7 @@
 
 (define-machine-types
   any
+  pb
   i3le      ti3le
   i3nt      ti3nt
   i3fb      ti3fb
@@ -393,7 +394,6 @@
   arm32le   tarm32le
   ppc32le   tppc32le
   arm64le   tarm64le
-  pb
   arm64osx  tarm64osx
 )
 

racket/src/ChezScheme/s/pb.ss

@@ -37,6 +37,9 @@
 ;;  |    op    | reg  reg |      immed/reg        |
 ;;  -----------------------------------------------
 ;;  -----------------------------------------------
+;;  |    op    | reg |          immed             | 
+;;  -----------------------------------------------
+;;  -----------------------------------------------
 ;;  |    op    |              immed               |
 ;;  -----------------------------------------------
 ;;
@@ -942,8 +945,8 @@
     (lambda (op dest offset code*)
       (emit-code (op dest offset code*)
         (constant pb-adr)
-        (ax-ea-reg-code dest)
+        (bitwise-ior (ax-ea-reg-code dest)
-        offset)))
+                     (bitwise-arithmetic-shift offset 4)))))
 
   (define inc-op
     (lambda (op dest src code*)
@@ -1396,6 +1399,8 @@
            (lambda (offset)
              (let ([incr-offset (adjust-return-point-offset incr-offset l)])
                (let ([disp (fx- next-addr (fx- offset incr-offset))])
+                 (unless (<= (- (expt 2 19)) disp (sub1 (expt 2 19)))
+                   (sorry! who "displacement to large for adr ~s" disp))
                  (emit adr `(reg . ,dest) disp '()))))]
           [else
            (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))]))))

racket/src/ChezScheme/workarea

@@ -113,6 +113,7 @@ case "$Muniarch" in
   i3qnx) March=i3 ;;
   i3s2) March=i3 ;;
   ppc32le) March=ppc32 ;;
+  pb) March=pb ;;
   *) March="" ;;
 esac
   

racket/src/cs/compile-file.ss

@@ -2,7 +2,7 @@
 ;; Check to make we're using a build of Chez Scheme
 ;; that has all the features we need.
 (define-values (need-maj need-min need-sub need-dev)
-  (values 9 5 3 52))
+  (values 9 5 3 53))
 
 (unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
   (error 'compile-file

racket/src/version/racket_version.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 9
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 9
+#define MZSCHEME_VERSION_W 10
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x