From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Sun, 22 Jul 1990 18:56:39 +0000 (+0000)
Subject: Update to version match 68k compiler version 4.74.
X-Git-Tag: 20090517-FFI~11302
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a396e3d82142aeeec7d8de78925bca146689d4ac;p=mit-scheme.git

Update to version match 68k compiler version 4.74.
Multi closures.
Bit-wise fixnum operations.
Add out-of-line multiply and divide (quotient and remainder) routines
that use the floating-point co-processor.
---

diff --git a/v7/src/compiler/machines/spectrum/compiler.pkg b/v7/src/compiler/machines/spectrum/compiler.pkg
index 5ab6a796f..b7ae446bd 100644
--- a/v7/src/compiler/machines/spectrum/compiler.pkg
+++ b/v7/src/compiler/machines/spectrum/compiler.pkg
@@ -1,7 +1,7 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/compiler.pkg,v 1.28 1990/03/26 23:46:08 jinx Exp $
-$MC68020-Header: comp.pkg,v 1.27 90/01/22 23:45:02 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/compiler.pkg,v 1.30 1990/07/22 18:49:57 jinx Rel $
+$MC68020-Header: comp.pkg,v 1.30 90/05/03 15:16:59 GMT jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -99,7 +99,8 @@ MIT in each case. |#
 	  compiler:show-phases?
 	  compiler:show-procedures?
 	  compiler:show-subphases?
-	  compiler:show-time-reports?))
+	  compiler:show-time-reports?
+	  compiler:use-multiclosures?))
 
 (define-package (compiler reference-contexts)
   (files "base/refctx")
@@ -397,7 +398,9 @@ MIT in each case. |#
   (parent (compiler fg-optimizer))
   (export (compiler top-level)
 	  setup-block-types!
-	  setup-closure-contexts!))
+	  setup-closure-contexts!)
+  (export (compiler)
+	  indirection-block-procedure))
 
 (define-package (compiler fg-optimizer simplicity-analysis)
   (files "fgopt/simple")
@@ -483,9 +486,13 @@ MIT in each case. |#
   (export (compiler rtl-generator)
 	  generate/rvalue
 	  load-closure-environment
+	  make-cons-closure-indirection
+	  make-cons-closure-redirection
+	  make-closure-redirection
 	  make-ic-cons
 	  make-non-trivial-closure-cons
-	  make-trivial-closure-cons))
+	  make-trivial-closure-cons
+	  redirect-closure))
 
 (define-package (compiler rtl-generator generate/combination)
   (files "rtlgen/rgcomb")
diff --git a/v7/src/compiler/machines/spectrum/decls.scm b/v7/src/compiler/machines/spectrum/decls.scm
index b0104e298..34411a3fb 100644
--- a/v7/src/compiler/machines/spectrum/decls.scm
+++ b/v7/src/compiler/machines/spectrum/decls.scm
@@ -1,7 +1,7 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/decls.scm,v 4.26 1990/03/26 23:36:42 jinx Exp $
-$MC68020-Header: decls.scm,v 4.26 90/02/02 18:39:26 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/decls.scm,v 4.27 1990/07/22 18:53:17 jinx Rel $
+$MC68020-Header: decls.scm,v 4.27 90/05/03 15:17:08 GMT jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -384,40 +384,44 @@ MIT in each case. |#
 			 (source-node/declarations node)))))
 	      filenames))
 
-  (let ((front-end-base
-	 (filename/append "base"
-			  "blocks" "cfg1" "cfg2" "cfg3"
-			  "contin" "ctypes" "enumer" "lvalue"
-			  "object" "proced" "rvalue"
-			  "scode" "subprb" "utils"))
-	(spectrum-base
-	 (filename/append "machines/spectrum" "machin"))
-	(rtl-base
-	 (filename/append "rtlbase"
-			  "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
-			  "rtlty2"))
-	(cse-base
-	 (filename/append "rtlopt"
-			  "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr"))
-	(instruction-base
-	 (filename/append "machines/spectrum" "assmd" "machin"))
-	(lapgen-base
-	 (append (filename/append "back" "lapgn3" "regmap")
-		 (filename/append "machines/spectrum" "lapgen")))
-	(assembler-base
-	 (append (filename/append "back" "symtab")
-		 (filename/append "machines/spectrum" "instr1")))
-	(lapgen-body
-	 (append
-	  (filename/append "back" "lapgn1" "lapgn2" "syntax")
-	  (filename/append "machines/spectrum"
-			   "rules1" "rules2" "rules3" "rules4"
-			   "rulfix" "rulflo")))
-	(assembler-body
-	 (append
-	  (filename/append "back" "bittop")
-	  (filename/append "machines/spectrum"
-			   "instr1" "instr2" "instr3"))))
+  (let* ((front-end-base
+	  (filename/append "base"
+			   "blocks" "cfg1" "cfg2" "cfg3"
+			   "contin" "ctypes" "enumer" "lvalue"
+			   "object" "proced" "rvalue"
+			   "scode" "subprb" "utils"))
+	 (spectrum-base
+	  (filename/append "machines/spectrum" "machin"))
+	 (rtl-base
+	  (filename/append "rtlbase"
+			   "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
+			   "rtlty2"))
+	 (cse-base
+	  (filename/append "rtlopt"
+			   "rcse1" "rcseht" "rcserq" "rcsesr"))
+	 (cse-all
+	  (append (filename/append "rtlopt"
+				   "rcse2" "rcseep")
+		  cse-base))
+	 (instruction-base
+	  (filename/append "machines/spectrum" "assmd" "machin"))
+	 (lapgen-base
+	  (append (filename/append "back" "lapgn3" "regmap")
+		  (filename/append "machines/spectrum" "lapgen")))
+	 (assembler-base
+	  (append (filename/append "back" "symtab")
+		  (filename/append "machines/spectrum" "instr1")))
+	 (lapgen-body
+	  (append
+	   (filename/append "back" "lapgn1" "lapgn2" "syntax")
+	   (filename/append "machines/spectrum"
+			    "rules1" "rules2" "rules3" "rules4"
+			    "rulfix" "rulflo")))
+	 (assembler-body
+	  (append
+	   (filename/append "back" "bittop")
+	   (filename/append "machines/spectrum"
+			    "instr1" "instr2" "instr3"))))
 
     (define (file-dependency/integration/join filenames dependencies)
       (for-each (lambda (filename)
@@ -509,13 +513,13 @@ MIT in each case. |#
      (append spectrum-base front-end-base rtl-base))
 
     (file-dependency/integration/join
-     (append cse-base
+     (append cse-all
 	     (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
 			      "rerite" "rinvex" "rlife" "rtlcsm")
 	     (filename/append "machines/spectrum" "rulrew"))
      (append spectrum-base rtl-base))
 
-    (file-dependency/integration/join cse-base cse-base)
+    (file-dependency/integration/join cse-all cse-base)
 
     (file-dependency/integration/join
      (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
diff --git a/v7/src/compiler/machines/spectrum/lapgen.scm b/v7/src/compiler/machines/spectrum/lapgen.scm
index f62893d3a..49824c5a1 100644
--- a/v7/src/compiler/machines/spectrum/lapgen.scm
+++ b/v7/src/compiler/machines/spectrum/lapgen.scm
@@ -1,7 +1,7 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/lapgen.scm,v 4.30 1990/04/09 20:35:44 cph Exp $
-$MC68020-Header: lapgen.scm,v 4.31 90/04/01 22:26:01 GMT jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/lapgen.scm,v 4.35 1990/07/22 18:53:55 jinx Rel $
+$MC68020-Header: lapgen.scm,v 4.35 90/07/20 15:53:40 GMT jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -34,6 +34,7 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;;; RTL Rules for HPPA.  Shared utilities.
+;;; package: (compiler lap-syntaxer)
 
 (declare (usual-integrations))
 
@@ -407,6 +408,7 @@ MIT in each case. |#
     (conversion source (standard-target! target))))
 
 (define (standard-binary-conversion source1 source2 target conversion)
+  ;; The sources are any register, `target' a pseudo register.
   (let ((source1 (standard-source! source1))
 	(source2 (standard-source! source2)))
     (conversion source1 source2 (standard-target! target))))
@@ -457,6 +459,9 @@ MIT in each case. |#
   (cdr (or (assq operator (cdr methods))
 	   (error "Unknown operator" operator))))
 
+(define-integrable (arithmetic-method? operator methods)
+  (assq operator (cdr methods)))  
+
 (define (fits-in-5-bits-signed? value)
   (<= #x-10 value #xF))
 
@@ -553,7 +558,17 @@ MIT in each case. |#
 			     (loop (cdr names) (+ 8 index)))))
 		 `(BEGIN ,@(loop names start)))))
   (define-hooks 100
-    store-closure-code))
+    store-closure-code
+    store-closure-entry			; newer version of store-closure-code.
+    multiply-fixnum
+    fixnum-quotient
+    fixnum-remainder
+    fixnum-lsh))
+
+(define (require-registers! . regs)
+  (let ((code (apply clear-registers! regs)))
+    (need-registers! regs)
+    code))
 
 (define (load-interface-args! first second third fourth)
   (let ((clear-regs
diff --git a/v7/src/compiler/machines/spectrum/machin.scm b/v7/src/compiler/machines/spectrum/machin.scm
index 3417b697a..d160003af 100644
--- a/v7/src/compiler/machines/spectrum/machin.scm
+++ b/v7/src/compiler/machines/spectrum/machin.scm
@@ -1,7 +1,7 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/machin.scm,v 4.21 1990/04/02 15:29:23 jinx Exp $
-$MC68020-Header: machin.scm,v 4.21 90/04/01 22:28:28 GMT jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/machin.scm,v 4.22 1990/07/22 18:54:22 jinx Rel $
+$MC68020-Header: machin.scm,v 4.22 90/05/03 15:17:20 GMT jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -34,6 +34,7 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;; Machine Model for Spectrum
+;;; package: (compiler)
 
 (declare (usual-integrations))
 
@@ -84,7 +85,68 @@ MIT in each case. |#
 
 (define-integrable (stack->memory-offset offset) offset)
 (define-integrable ic-block-first-parameter-offset 2)
-(define-integrable closure-block-first-offset 3)
+(define-integrable execute-cache-size 3) ; Long words per UUO link slot
+
+;;;; Closures and multi-closures
+
+;; On the 68k, to save space, entries can be at 2 mod 4 addresses,
+;; which makes it impossible to use an arbitrary closure entry-point
+;; to reference closed-over variables since the compiler only uses
+;; long-word offsets.  Instead, all closure entry points are bumped
+;; back to the first entry point, which is always long-word aligned.
+
+;; On the HP-PA, and all other RISCs, all the entry points are
+;; long-word aligned, so there is no need to bump back to the first
+;; entry point.
+
+(define-integrable closure-entry-size
+  #|
+     Long words in a single closure entry:
+       GC offset word
+       LDIL	L'target,26
+       BLE	R'target(5,26)
+       ADDI	-12,31,31
+   |#
+  4)
+
+;; Given: the number of entry points in a closure, and a particular
+;; entry point number, compute the distance from that entry point to
+;; the first variable slot in the closure object (in long words).
+
+(define (closure-first-offset nentries entry)
+  (if (zero? nentries)
+      1					; Strange boundary case
+      (- (* closure-entry-size (- nentries entry)) 1)))
+
+;; Like the above, but from the start of the complete closure object,
+;; viewed as a vector, and including the header word.
+
+(define (closure-object-first-offset nentries)
+  (case nentries
+    ((0)
+     ;; Vector header only
+     1)
+    ((1)
+     ;; Manifest closure header followed by single entry point
+     (+ 1 closure-entry-size))
+    (else
+     ;; Manifest closure header, number of entries, then entries.
+     (+ 1 1 (* closure-entry-size nentries)))))
+
+;; Bump distance in bytes from one entry point to another.
+;; Used for invocation purposes.
+
+(define (closure-entry-distance nentries entry entry*)
+  nentries				; ignored
+  (* (* closure-entry-size 4) (- entry* entry)))
+
+;; Bump distance in bytes from one entry point to the entry point used
+;; for variable-reference purposes.
+;; On a RISC, this is the entry point itself.
+
+(define (closure-environment-adjustment nentries entry)
+  nentries entry			; ignored
+  0)
 
 ;;;; Machine Registers
 
@@ -328,8 +390,7 @@ MIT in each case. |#
   true)
 
 (define compiler:primitives-with-no-open-coding
-  '(MULTIPLY-FIXNUM INTEGER-MULTIPLY &*
-    DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER
+  '(INTEGER-MULTIPLY DIVIDE-FIXNUM GCD-FIXNUM
     INTEGER-QUOTIENT INTEGER-REMAINDER &/
     FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS
     FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/spectrum/make.scm b/v7/src/compiler/machines/spectrum/make.scm
index 09517242b..14a54cd4a 100644
--- a/v7/src/compiler/machines/spectrum/make.scm
+++ b/v7/src/compiler/machines/spectrum/make.scm
@@ -1,7 +1,7 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/make.scm,v 4.72 1990/04/03 06:17:26 jinx Exp $
-$MC68020-Header: make.scm,v 4.72 90/04/03 04:50:08 GMT jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/make.scm,v 4.74 1990/07/22 18:54:44 jinx Exp $
+$MC68020-Header: make.scm,v 4.74 90/06/26 22:07:13 GMT jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -42,4 +42,4 @@ MIT in each case. |#
 	    ((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
 	  '((COMPILER MACROS)
 	    (COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (HP PA)" 4 72 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (HP PA)" 4 74 '()))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/spectrum/rules1.scm b/v7/src/compiler/machines/spectrum/rules1.scm
index 12ac64ec2..4a5e887af 100644
--- a/v7/src/compiler/machines/spectrum/rules1.scm
+++ b/v7/src/compiler/machines/spectrum/rules1.scm
@@ -1,7 +1,7 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules1.scm,v 4.32 1990/01/25 16:39:51 jinx Exp $
-$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules1.scm,v 4.33 1990/07/22 18:55:17 jinx Rel $
+$MC68020-Header: rules1.scm,v 4.33 90/05/03 15:17:28 GMT jinx Exp $
 
 Copyright (c) 1989, 1990 Massachusetts Institute of Technology
 
@@ -34,6 +34,7 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;;; LAP Generation Rules: Data Transfers
+;;; package: (compiler lap-syntaxer)
 
 (declare (usual-integrations))
 
@@ -63,7 +64,8 @@ MIT in each case. |#
   ;; tag the contents of a register
   (ASSIGN (REGISTER (? target))
 	  (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
-  (QUALIFIER (fits-in-5-bits-signed? type))
+  ;; *** Why doesn't it work when qualifier is used? ***
+  ;; (QUALIFIER (fits-in-5-bits-signed? type))
   (deposit-type type (standard-move-to-target! source target)))
 
 (define-rule statement
@@ -82,13 +84,21 @@ MIT in each case. |#
   (object->address (standard-move-to-target! source target)))
 
 (define-rule statement
-  ;; add a constant to a register's contents
+  ;; add a constant offset (in long words) to a register's contents
   (ASSIGN (REGISTER (? target))
 	  (OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
   (standard-unary-conversion source target
     (lambda (source target)
       (load-offset (* 4 offset) source target))))
 
+(define-rule statement
+  ;; add a constant offset (in bytes) to a register's contents
+  (ASSIGN (REGISTER (? target))
+	  (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
+  (standard-unary-conversion source target
+    (lambda (source target)
+      (load-offset offset source target))))
+
 (define-rule statement
   ;; read an object from memory
   (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
diff --git a/v7/src/compiler/machines/spectrum/rules3.scm b/v7/src/compiler/machines/spectrum/rules3.scm
index 9e06cfe74..16f632e45 100644
--- a/v7/src/compiler/machines/spectrum/rules3.scm
+++ b/v7/src/compiler/machines/spectrum/rules3.scm
@@ -1,7 +1,7 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules3.scm,v 4.24 1990/04/09 21:07:36 cph Exp $
-$MC68020-Header: rules3.scm,v 4.23 90/01/18 22:44:09 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules3.scm,v 4.25 1990/07/22 18:55:38 jinx Exp $
+$MC68020-Header: rules3.scm,v 4.24 90/05/03 15:17:33 GMT jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -34,6 +34,7 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
 
 (declare (usual-integrations))
 
@@ -417,75 +418,143 @@ MIT in each case. |#
 
 ;;;; Closures.  These two statements are intertwined:
 
-;; Magic for compiled entries.
-
-(define compiled-entry-type-im5
-  (let* ((qr (integer-divide (ucode-type compiled-entry) 2))
-	 (immed (integer-divide-quotient qr)))
-    (if (or (not (= scheme-type-width 6))
-	    (not (zero? (integer-divide-remainder qr)))
-	    (not (<= 0 immed #x1F)))
-	(error "closure header rule assumptions violated!"))
-    (if (<= immed #x0F)
-	immed
-	(- immed #x20))))
-
-(define-integrable (address->entry register)
-  (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register)))
-
 (define-rule statement
   ;; This depends on the following facts:
-  ;; 1- tc_compiled_entry is a multiple of two.
+  ;; 1- TC_COMPILED_ENTRY is a multiple of two.
   ;; 2- all the top 6 bits in a data address are 0 except the quad bit
   ;; 3- type codes are 6 bits long.
-  (CLOSURE-HEADER (? internal-label))
+  (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+  entry				; Used only if entries may not be word-aligned.
+  (if (zero? nentries)
+      (error "Closure header for closure with no entries!"
+	     internal-label))
   (let ((procedure (label->object internal-label)))
     (let ((gc-label (generate-label))
 	  (external-label (rtl-procedure/external-label procedure)))
       (LAP (LABEL ,gc-label)
 	   ,@(invoke-interface code:compiler-interrupt-closure)
 	   ,@(make-external-label internal-entry-code-word external-label)
+	   ;; This code must match the code and count in microcode/cmpint2.h
 	   (DEP () 0 31 2 ,regnum:ble-return)
 	   ,@(address->entry regnum:ble-return)
 	   (STWM () ,regnum:ble-return (OFFSET -4 0 22))
 	   (LABEL ,internal-label)
 	   ,@(interrupt-check gc-label)))))
 
-(define (cons-closure target label min max size ->entry?)
-  (let ((flush-reg (clear-registers! regnum:ble-return)))
-    (need-register! regnum:ble-return)
-    (let ((dest (standard-target! target)))
-      ;; Note: dest is used as a temporary before the BLE instruction,
-      ;; and is written immediately afterwards.
-      (LAP ,@flush-reg
-	   ,@(load-non-pointer (ucode-type manifest-closure) (+ 4 size) dest)
-	   (STWM () ,dest (OFFSET 4 0 21))
-	   ,@(load-immediate
-	      (+ (* (make-procedure-code-word min max) #x10000) 4)
-	      dest)
-	   (STWM () ,dest (OFFSET 4 0 21))
-	   ,@(load-pc-relative-address
-	      (rtl-procedure/external-label (label->object label))
-	      1)
-	   (BLE ()
-		(OFFSET ,hook:compiler-store-closure-code
-			4
-			,regnum:scheme-to-interface-ble))
-	   (COPY () ,regnum:free-pointer ,dest)
-	   ,@(if ->entry?
-		 (address->entry dest)
-		 (LAP))
-	   ,@(load-offset (* 4 size)
-			  regnum:free-pointer
-			  regnum:free-pointer)))))
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+	  (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+			(? min) (? max) (? size)))
+  (cons-closure target procedure-label min max size))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
-	  (CONS-POINTER (MACHINE-CONSTANT (? type))
-			(CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
-				      (? min) (? max) (? size))))
-  (QUALIFIER (= type (ucode-type compiled-entry)))
-  (cons-closure target procedure-label min max size true))
+	  (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
+  ;; entries is a vector of all the entry points
+  (case nentries
+    ((0)
+     (let ((dest (standard-target! target)))
+       (LAP ,@(load-non-pointer (ucode-type manifest-vector)
+				(+ 4 size)
+				dest)
+	    (STWM () ,dest (OFFSET 4 0 ,regnum:free-pointer))
+	    ,@(load-offset -4 regnum:free-pointer dest))))
+    ((1)
+     (let ((entry (vector-ref entries 0)))
+       (cons-closure
+	target (car entry) (cadr entry) (caddr entry) size)))
+    (else
+     (cons-multiclosure target nentries size (vector->list entries)))))
+
+(define (cons-closure target entry min max size)
+  (let* ((flush-reg (require-registers! regnum:first-arg
+					#| regnum:addil-result |#
+				        regnum:ble-return))
+	 (target (standard-target! target)))
+    (LAP ,@flush-reg
+	 ;; Vector header
+	 ,@(load-non-pointer (ucode-type manifest-closure)
+			     (+ size closure-entry-size)
+			     regnum:first-arg)
+	 (STWM () ,regnum:first-arg (OFFSET 4 0 ,regnum:free-pointer))
+	 ;; Entry point is result.
+	 ,@(load-offset 4 regnum:free-pointer target)
+	 ,@(cons-closure-entry entry min max 8)
+	 ;; Allocate space for closed-over variables
+	 ,@(load-offset (* 4 size)
+			regnum:free-pointer
+			regnum:free-pointer))))
+
+(define (cons-multiclosure target nentries size entries)
+  (let* ((flush-reg (require-registers! regnum:first-arg
+					#| regnum:addil-result |#
+					regnum:ble-return))
+	 (target (standard-target! target)))
+    (define (generate-entries offset entries)
+      (if (null? entries)
+	  (LAP)
+	  (let ((entry (car entries)))
+	    (LAP ,@(cons-closure-entry (car entry) (cadr entry) (caddr entry)
+				       offset)
+		 ,@(generate-entries (+ offset (* 4 closure-entry-size))
+				     (cdr entries))))))
+
+    (LAP ,@flush-reg
+	 ;; Vector header
+	 ,@(load-non-pointer (ucode-type manifest-closure)
+			     (+ 1 (* closure-entry-size nentries) size)
+			     regnum:first-arg)
+	 (STWM () ,regnum:first-arg (offset 4 0 ,regnum:free-pointer))
+	 ;; Number of closure entries
+	 ,@(load-entry-format nentries 0 target)
+	 (STWM () ,target (offset 4 0 ,regnum:free-pointer))
+	 ;; First entry point is result.
+	 ,@(load-offset 4 21 target)
+	 ,@(generate-entries 12 entries)
+	 ;; Allocate space for closed-over variables
+	 ,@(load-offset (* 4 size)
+			regnum:free-pointer
+			regnum:free-pointer))))
+
+;; Magic for compiled entries.
+
+(define compiled-entry-type-im5
+  (let* ((qr (integer-divide (ucode-type compiled-entry) 2))
+	 (immed (integer-divide-quotient qr)))
+    (if (or (not (= scheme-type-width 6))
+	    (not (zero? (integer-divide-remainder qr)))
+	    (not (<= 0 immed #x1F)))
+	(error "HPPA RTL rules3: closure header rule assumptions violated!"))
+    (if (<= immed #x0F)
+	immed
+	(- immed #x20))))
+
+(define-integrable (address->entry register)
+  (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register)))
+
+(define (load-entry-format code-word gc-offset dest)
+  (load-immediate (+ (* code-word #x10000)
+		     (quotient gc-offset 2))
+		  dest))
+
+(define (cons-closure-entry entry min max offset)
+  ;; Call an out-of-line hook to do this.
+  ;; Making the instructions is a lot of work!
+  ;; Perhaps there should be a closure hook invoked and the real
+  ;; entry point could follow.  It would also be easier on the GC.
+  (let ((entry-label (rtl-procedure/external-label (label->object entry))))
+    (LAP ,@(load-entry-format (make-procedure-code-word min max)
+			      offset
+			      regnum:first-arg)
+	 (BLE ()
+	      (OFFSET ,hook:compiler-store-closure-entry
+		      4
+		      ,regnum:scheme-to-interface-ble))
+	 (LDO ()
+	      (OFFSET (- ,entry-label (+ *PC* 4))
+		      0
+		      ,regnum:ble-return)
+	      ,regnum:addil-result))))
 
 ;;;; Entry Header
 ;;; This is invoked by the top level of the LAP generator.
diff --git a/v7/src/compiler/machines/spectrum/rulfix.scm b/v7/src/compiler/machines/spectrum/rulfix.scm
index 484af79f4..a74a6062c 100644
--- a/v7/src/compiler/machines/spectrum/rulfix.scm
+++ b/v7/src/compiler/machines/spectrum/rulfix.scm
@@ -1,7 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rulfix.scm,v 4.34 1990/04/02 15:30:02 jinx Exp $
-$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rulfix.scm,v 4.35 1990/07/22 18:56:13 jinx Exp $
+$MC68020-Header: rules1.scm,v 4.33 90/05/03 15:17:28 GMT jinx Exp $
+$MC68020-Header: lapgen.scm,v 4.35 90/07/20 15:53:40 GMT jinx Exp $
 
 Copyright (c) 1989, 1990 Massachusetts Institute of Technology
 
@@ -34,6 +35,7 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;;; LAP Generation Rules: Fixnum Rules
+;;; package: (compiler lap-syntaxer)
 
 (declare (usual-integrations))
 
@@ -85,6 +87,9 @@ MIT in each case. |#
 			 (OBJECT->FIXNUM (CONSTANT 4))
 			 #F))
   (standard-unary-conversion source target object->index-fixnum))
+
+#|
+;; Superseded by code below
 
 ;; This is a patch for the time being.  Probably only one of these pairs
 ;; of rules is needed.
@@ -104,6 +109,7 @@ MIT in each case. |#
 			 (OBJECT->FIXNUM (CONSTANT 4))
 			 #F))
   (standard-unary-conversion source target fixnum->index-fixnum))
+|#
 
 (define-integrable (fixnum->index-fixnum src tgt)
   (LAP (SHD () ,src 0 30 ,tgt)))
@@ -139,28 +145,20 @@ MIT in each case. |#
 	  (FIXNUM-1-ARG (? operation)
 			(REGISTER (? source))
 			(? overflow?)))
+  (QUALIFIER (fixnum-1-arg/operator? operation))
   (standard-unary-conversion source target
     (lambda (source target)
       ((fixnum-1-arg/operator operation) target source overflow?))))
 
-(define (fixnum-1-arg/operator operation)
+(define-integrable (fixnum-1-arg/operator operation)
   (lookup-arithmetic-method operation fixnum-methods/1-arg))
 
+(define-integrable (fixnum-1-arg/operator? operation)
+  (arithmetic-method? operation fixnum-methods/1-arg))
+
 (define fixnum-methods/1-arg
   (list 'FIXNUM-METHODS/1-ARG))
 
-(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
-  (lambda (tgt src overflow?)
-    (if overflow?
-	(LAP (ADDI (NSV) ,fixnum-1 ,src ,tgt))
-	(LAP (ADDI () ,fixnum-1 ,src ,tgt)))))
-
-(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
-  (lambda (tgt src overflow?)
-    (if overflow?
-	(LAP (ADDI (NSV) ,(- fixnum-1) ,src ,tgt))
-	(LAP (ADDI () ,(- fixnum-1) ,src ,tgt)))))
-
 (define-rule statement
   ;; execute a binary fixnum operation
   (ASSIGN (REGISTER (? target))
@@ -168,28 +166,127 @@ MIT in each case. |#
 			 (REGISTER (? source1))
 			 (REGISTER (? source2))
 			 (? overflow?)))
+  (QUALIFIER (fixnum-2-args/operator? operation))
   (standard-binary-conversion source1 source2 target
     (lambda (source1 source2 target)
       ((fixnum-2-args/operator operation) target source1 source2 overflow?))))
 
-(define (fixnum-2-args/operator operation)
+(define-integrable (fixnum-2-args/operator operation)
   (lookup-arithmetic-method operation fixnum-methods/2-args))
 
+(define-integrable (fixnum-2-args/operator? operation)
+  (arithmetic-method? operation fixnum-methods/2-args))
+
 (define fixnum-methods/2-args
   (list 'FIXNUM-METHODS/2-ARGS))
 
-(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
-  (lambda (tgt src1 src2 overflow?)
-    (if overflow?
-	(LAP (ADD (NSV) ,src1 ,src2 ,tgt))
-	(LAP (ADD () ,src1 ,src2 ,tgt)))))
-
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
-  (lambda (tgt src1 src2 overflow?)
-    (if overflow?
-	(LAP (SUB (NSV) ,src1 ,src2 ,tgt))
-	(LAP (SUB () ,src1 ,src2 ,tgt)))))
+;; Some operations are too long to do in-line.
+;; Use out-of-line utilities.
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+	  (FIXNUM-2-ARGS (? operation)
+			 (REGISTER (? source1))
+			 (REGISTER (? source2))
+			 (? overflow?)))
+  (QUALIFIER (fixnum-2-args/special-operator? operation))
+  (special-binary-operation
+   operation
+   (fixnum-2-args/special-operator operation)
+   target source1 source2 overflow?))
+
+(define-integrable (fixnum-2-args/special-operator operation)
+  (lookup-arithmetic-method operation fixnum-methods/2-args/special))
+
+(define-integrable (fixnum-2-args/special-operator? operation)
+  (arithmetic-method? operation fixnum-methods/2-args/special))
+
+(define fixnum-methods/2-args/special
+  (list 'FIXNUM-METHODS/2-ARGS/SPECIAL))
+
+;; Note: Bit-wise operations never overflow, therefore they always
+;; skip the branch (cond = TR).  Perhaps they should error?
+
+;; Note: The commas in the macros do not follow normal QUASIQUOTE patterns.
+;; This is due to a bad interaction between QUASIQUOTE and LAP!
+
+(let-syntax
+    ((unary-fixnum
+      (macro (name instr nsv fixed-operand)
+	`(define-arithmetic-method ',name fixnum-methods/1-arg
+	   (lambda (tgt src overflow?)
+	     (if overflow?
+		 (LAP (,instr (,nsv) ,fixed-operand ,',src ,',tgt))
+		 (LAP (,instr () ,fixed-operand ,',src ,',tgt)))))))
+
+     (binary-fixnum
+      (macro (name instr nsv)
+	`(define-arithmetic-method ',name fixnum-methods/2-args
+	   (lambda (tgt src1 src2 overflow?)
+	     (if overflow?
+		 (LAP (,instr (,nsv) ,',src1 ,',src2 ,',tgt))
+		 (LAP (,instr () ,',src1 ,',src2 ,',tgt)))))))
+
+     (binary-out-of-line
+      (macro (name . regs)
+	`(define-arithmetic-method ',name fixnum-methods/2-args/special
+	   (cons ,(symbol-append 'HOOK:COMPILER- name)
+		 (lambda ()
+		   ,(if (null? regs)
+			`(LAP)
+			`(require-registers! ,@regs))))))))
+
+  (unary-fixnum ONE-PLUS-FIXNUM ADDI NSV ,fixnum-1)
+  (unary-fixnum MINUS-ONE-PLUS-FIXNUM ADDI NSV ,(- fixnum-1))
+  (unary-fixnum FIXNUM-NOT SUBI TR ,(- fixnum-1))
+
+  (binary-fixnum PLUS-FIXNUM ADD NSV)
+  (binary-fixnum MINUS-FIXNUM SUB NSV)
+  (binary-fixnum FIXNUM-AND AND TR)
+  (binary-fixnum FIXNUM-ANDC ANDCM TR)
+  (binary-fixnum FIXNUM-OR OR TR)
+  (binary-fixnum FIXNUM-XOR XOR TR)
+
+  (binary-out-of-line MULTIPLY-FIXNUM fp4 fp5)
+  (binary-out-of-line FIXNUM-QUOTIENT fp4 fp5)
+  (binary-out-of-line FIXNUM-REMAINDER fp4 fp5 regnum:addil-result)
+  (binary-out-of-line FIXNUM-LSH))
 
+;;; Out of line calls.
+
+;; Arguments are passed in regnum:first-arg and regnum:second-arg.
+;; Result is returned in regnum:first-arg, and a boolean is returned
+;; in regnum:second-arg indicating wheter there was overflow.
+
+(define (special-binary-operation operation hook target source1 source2 ovflw?)
+  (define (->machine-register source machine-reg)
+    (let ((code (load-machine-register! source machine-reg)))
+      ;; Prevent it from being allocated again.
+      (need-register! machine-reg)
+      code))
+
+  (if (not (pair? hook))
+      (error "special-binary-operation: Unknown operation" operation))
+
+  (let* ((extra ((cdr hook)))
+	 (load-1 (->machine-register source1 regnum:first-arg))		      
+	 (load-2 (->machine-register source2 regnum:second-arg)))
+    ;; Make regnum:first-arg the only alias for target
+    (delete-register! target)
+    (add-pseudo-register-alias! target regnum:first-arg)
+    (LAP ,@extra
+	 ,@load-1
+	 ,@load-2
+	 ;; Hopefully a peep-hole optimizer will switch this instruction
+	 ;; and the preceding one, and remove the nop.
+	 (BLE () (OFFSET ,(car hook) 4 ,regnum:scheme-to-interface-ble))
+	 (NOP ())
+	 ,@(if (not ovflw?)
+	       (LAP)
+	       (LAP (COMICLR (=) 0 ,regnum:second-arg 0))))))
+
+;;; Binary operations with one argument constant.
+
 (define-rule statement
   ;; execute binary fixnum operation with constant second arg
   (ASSIGN (REGISTER (? target))
@@ -197,6 +294,8 @@ MIT in each case. |#
 			 (REGISTER (? source))
 			 (OBJECT->FIXNUM (CONSTANT (? constant)))
 			 (? overflow?)))
+  (QUALIFIER
+   (fixnum-2-args/operator/register*constant? operation constant overflow?))
   (standard-unary-conversion source target
     (lambda (source target)
       ((fixnum-2-args/operator/register*constant operation)
@@ -209,6 +308,8 @@ MIT in each case. |#
 			 (OBJECT->FIXNUM (CONSTANT (? constant)))
 			 (REGISTER (? source))
 			 (? overflow?)))
+  (QUALIFIER
+   (fixnum-2-args/operator/constant*register? operation constant overflow?))
   (standard-unary-conversion source target
     (lambda (source target)
       (if (fixnum-2-args/commutative? operation)
@@ -217,16 +318,59 @@ MIT in each case. |#
 	  ((fixnum-2-args/operator/constant*register operation)
 	   target constant source overflow?)))))
 
-(define (fixnum-2-args/commutative? operator)
-  (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM)))
+(define (define-arithconst-method name table qualifier code-gen)
+  (define-arithmetic-method name table
+    (cons code-gen qualifier)))
 
-(define (fixnum-2-args/operator/register*constant operation)
-  (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant))
+(define (fixnum-2-args/commutative? operator)
+  (memq operator '(PLUS-FIXNUM
+		   MULTIPLY-FIXNUM
+		   FIXNUM-AND
+		   FIXNUM-OR
+		   FIXNUM-XOR)))
+
+(define-integrable (fixnum-2-args/operator/register*constant operation)
+  (car (lookup-arithmetic-method operation
+				 fixnum-methods/2-args/register*constant)))
+
+(define (fixnum-2-args/operator/register*constant? operation constant ovflw?)
+  (let ((handler (arithmetic-method? operation
+				     fixnum-methods/2-args/register*constant)))
+    (and handler
+	 ((cddr handler) constant ovflw?))))
 
 (define fixnum-methods/2-args/register*constant
   (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
 
-(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args/register*constant
+(define-integrable (fixnum-2-args/operator/constant*register operation)
+  (car (lookup-arithmetic-method operation
+				 fixnum-methods/2-args/constant*register)))
+
+(define (fixnum-2-args/operator/constant*register? operation constant ovflw?)
+  (let ((handler (arithmetic-method? operation
+				     fixnum-methods/2-args/constant*register)))
+    (or (and handler
+	     ((cddr handler) constant ovflw?))
+	(and (fixnum-2-args/commutative? operation)
+	     (fixnum-2-args/operator/register*constant? operation
+							constant ovflw?)))))
+
+(define fixnum-methods/2-args/constant*register
+  (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
+
+(define (guarantee-signed-fixnum n)
+  (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
+  n)
+
+(define (signed-fixnum? n)
+  (and (exact-integer? n)
+       (>= n signed-fixnum/lower-limit)
+       (< n signed-fixnum/upper-limit)))
+
+(define-arithconst-method 'PLUS-FIXNUM fixnum-methods/2-args/register*constant
+  (lambda (constant ovflw?)
+    ovflw?					; ignored
+    (fits-in-11-bits-signed? (* constant fixnum-1)))
   (lambda (tgt src constant overflow?)
     (guarantee-signed-fixnum constant)
     (let ((value (* constant fixnum-1)))
@@ -241,7 +385,10 @@ MIT in each case. |#
 			(ADD (NSV) ,src ,temp ,tgt)))))
 	  (load-offset value src tgt)))))
 
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/register*constant
+(define-arithconst-method 'MINUS-FIXNUM fixnum-methods/2-args/register*constant
+  (lambda (constant ovflw?)
+    ovflw?					; ignored
+    (fits-in-11-bits-signed? (* constant fixnum-1)))
   (lambda (tgt src constant overflow?)
     (guarantee-signed-fixnum constant)
     (let ((value (- (* constant fixnum-1))))
@@ -256,13 +403,10 @@ MIT in each case. |#
 			(SUB (NSV) ,src ,temp ,tgt)))))
 	  (load-offset value src tgt)))))
 
-(define (fixnum-2-args/operator/constant*register operation)
-  (lookup-arithmetic-method operation fixnum-methods/2-args/constant*register))
-
-(define fixnum-methods/2-args/constant*register
-  (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
-
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/constant*register
+(define-arithconst-method 'MINUS-FIXNUM fixnum-methods/2-args/constant*register
+  (lambda (constant ovflw?)
+    ovflw?					; ignored
+    (fits-in-11-bits-signed? (* constant fixnum-1)))
   (lambda (tgt constant src overflow?)
     (guarantee-signed-fixnum constant)
     (let ((value (* constant fixnum-1)))
@@ -275,27 +419,270 @@ MIT in each case. |#
 		 ,@(if overflow?
 		       (LAP (SUB (NSV) ,temp ,src ,tgt))
 		       (LAP (SUB () ,temp ,src ,tgt)))))))))
+
+(define-arithconst-method 'FIXNUM-LSH fixnum-methods/2-args/register*constant
+  (lambda (constant ovflw?)
+    constant ovflw?				; ignored
+    true)
+  (lambda (tgt src shift overflow?)
+    ;; What does overflow mean for a logical shift?
+    ;; The code commented out below corresponds to arithmetic shift
+    ;; overflow conditions.
+    (guarantee-signed-fixnum shift)
+    (cond ((zero? shift)
+	   (cond ((not overflow?)
+		  (copy src tgt))
+		 ((= src tgt)
+		  (LAP (SKIP (TR))))
+		 (else
+		  (LAP (COPY (TR) ,src ,tgt)))))
+	  ((negative? shift)
+	   ;; Right shift
+	   (let ((shift (- shift)))
+	     (cond ((< shift scheme-datum-width)
+		    (LAP (SHD () 0 ,src ,shift ,tgt)
+			 ;; clear shifted bits
+			 (DEP (,(if overflow? 'TR 'NV))
+			       0 31 ,scheme-type-width ,tgt)))
+		   ((not overflow?)
+		    (copy 0 tgt))
+		   (else
+		    (LAP (COPY (TR) 0 ,tgt))))))
+	  (else
+	   ;; Left shift
+	   (cond ((>= shift scheme-datum-width)
+		  (if (not overflow?)
+		      (copy 0 tgt)
+		      #| (LAP (COMICLR (=) 0 ,src ,tgt)) |#
+		      (LAP (COMICLR (TR) 0 ,src ,tgt))))
+		 (overflow?
+		  #|
+		  ;; Arithmetic overflow condition accomplished
+		  ;; by skipping all over the place.
+		  ;; Another possibility is to use the shift-and-add
+		  ;; instructions, that compute correct signed overflow
+		  ;; conditions.
+		  (let ((nkept (- 32 shift))
+			(temp (standard-temporary!)))
+		    (LAP (ZDEP () ,src ,(- nkept 1) ,nkept ,tgt)
+			 (EXTRS (=) ,src ,(- shift 1) ,shift ,temp)
+			 (COMICLR (<>) -1 ,temp 0)
+			 (SKIP (TR))))
+		  |#
+		  (LAP (ZDEP (TR) ,src ,(- nbits 1) ,nbits ,tgt)))
+		 (else
+		  (let ((nbits (- 32 shift)))
+		    (LAP (ZDEP () ,src ,(- nbits 1) ,nbits ,tgt)))))))))
+
+(define-integrable (divisible? m n)
+  (zero? (remainder m n)))
+
+(define (integer-log-base-2? n)
+  (let loop ((power 1) (exponent 0))
+    (cond ((< n power) false)
+	  ((= n power) exponent)
+	  (else
+	   (loop (* 2 power) (1+ exponent))))))
+
+(define-arithconst-method 'MULTIPLY-FIXNUM
+  fixnum-methods/2-args/register*constant
+  (lambda (constant ovflw?)
+    (let ((factor (abs constant)))
+      (or (integer-log-base-2? factor)
+	  (and (<= factor 64)
+	       (or (not ovflw?)
+		   (<= factor (expt 2 scheme-type-width)))))))
 
-(define (guarantee-signed-fixnum n)
-  (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
-  n)
-
-(define (signed-fixnum? n)
-  (and (exact-integer? n)
-       (>= n signed-fixnum/lower-limit)
-       (< n signed-fixnum/upper-limit)))
+  (lambda (tgt src constant overflow?)
+    (guarantee-signed-fixnum constant)
+    (let ((skip (if overflow? 'NSV 'NV)))
+      (case constant
+	((0)
+	 (if overflow?
+	     (LAP (COPY (TR) 0 ,tgt))
+	     (LAP (COPY () 0 ,tgt))))
+	((1)
+	 (if overflow?
+	     (LAP (COPY (TR) ,src ,tgt))
+	     (copy src tgt)))
+	((-1)
+	 (LAP (SUB (,skip) 0 ,src ,tgt)))
+	(else
+	 (let* ((factor (abs constant))
+		(src+ (if (negative? constant) tgt src))
+		(xpt (integer-log-base-2? factor)))
+	   (cond ((not overflow?)
+		  (LAP ,@(if (negative? constant)
+			     (LAP (SUB () 0 ,src ,tgt))
+			     (LAP))
+		       ,@(if xpt
+			     (LAP (SHD () ,src+ 0 ,(- 32 xpt) ,tgt))
+			     (expand-factor tgt src+ factor false 'NV
+					    (lambda ()
+					      (LAP))))))
+		 ((and xpt (> xpt 6))
+		  (let* ((high (standard-temporary!))
+			 (low (if (or (= src tgt) (negative? constant))
+				  (standard-temporary!)
+				  src))
+			 (nbits (- 32 xpt))
+			 (core
+			  (LAP (SHD () ,low 0 ,nbits ,tgt)
+			       (SHD (=) ,high ,low ,(-1+ nbits) ,high)
+			       (COMICLR (<>) -1 ,high 0)
+			       (SKIP (TR)))))
+		    (if (negative? constant)
+			(LAP (EXTRS () ,src 0 1 ,high)
+			     (SUB () 0 ,src ,low)
+			     (SUBB () 0 ,high ,high)
+			     ,@core)
+			(LAP ,@(if (not (= src low))
+				   (LAP (COPY () ,src ,low))
+				   (LAP))
+			     (EXTRS () ,low 0 1 ,high)
+			     ,@core))))
+		 (else
+		  (LAP ,@(if (negative? constant)
+			     (LAP (SUB (SV) 0 ,src ,tgt))
+			     (LAP))
+		       ,@(expand-factor tgt src+ factor (negative? constant)
+					'NSV
+					(lambda ()
+					  (LAP (SKIP (TR))))))))))))))
+
+(define (expand-factor tgt src factor skipping? condition skip)
+  (define (sh3add condition src1 src2 tgt)
+    (LAP (SH3ADD (,condition) ,src1 ,src2 ,tgt)))
+
+  (define (sh2add condition src1 src2 tgt)
+    (LAP (SH2ADD (,condition) ,src1 ,src2 ,tgt)))
+
+  (define (sh1add condition src1 src2 tgt)
+    (LAP (SH1ADD (,condition) ,src1 ,src2 ,tgt)))
+
+  (define (handle factor fixed)
+    (define (wrap instr next value)
+      (let ((code? (car next))
+	    (result-reg (cadr next))
+	    (temp-reg (caddr next))
+	    (code (cadddr next)))
+	(list true
+	      tgt
+	      temp-reg
+	      (LAP ,@code
+		   ,@(if code?
+			 (skip)
+			 (LAP))
+		   ,@(instr condition result-reg value tgt)))))
+
+    (cond ((zero? factor) (list false 0 fixed (LAP)))
+	  ((= factor 1) (list false fixed fixed (LAP)))
+	  ((divisible? factor 8)
+	   (wrap sh3add (handle (/ factor 8) fixed) 0))
+	  ((divisible? factor 4)
+	   (wrap sh2add (handle (/ factor 4) fixed) 0))
+	  ((divisible? factor 2)
+	   (wrap sh1add (handle (/ factor 2) fixed) 0))
+	  (else
+	   (let* ((f1 (-1+ factor))
+		  (fixed (if (or (not (= fixed src))
+				 (not (= src tgt))
+				 (and (integer-log-base-2? f1)
+				      (< f1 16)))
+			   fixed
+			   (standard-temporary!))))
+	     (cond ((divisible? f1 8)
+		    (wrap sh3add (handle (/ f1 8) fixed) fixed))
+		   ((divisible? f1 4)
+		    (wrap sh2add (handle (/ f1 4) fixed) fixed))
+		   (else
+		    (wrap sh1add (handle (/ f1 2) fixed) fixed)))))))
+
+  (let ((result (handle factor src)))
+    (let ((result-reg (cadr result))
+	  (temp-reg (caddr result))
+	  (code (cadddr result)))
+      
+      (LAP ,@(cond ((= temp-reg src)
+		    (LAP))
+		   ((not skipping?)
+		    (LAP (COPY () ,src ,temp-reg)))
+		   (else
+		    (LAP (COPY (TR) ,src ,temp-reg)
+			 ,@(skip))))
+	   ,@code
+	   ,@(cond ((= result-reg tgt)
+		    (LAP))
+		   ((eq? concition 'NV)
+		    (LAP (COPY () ,result-reg ,tgt)))
+		   (else
+		    (LAP (COPY (TR) ,result-reg ,tgt)
+			 ,@(skip))))))))
+
+;;;; Division
+
+(define-arithconst-method 'FIXNUM-QUOTIENT
+  fixnum-methods/2-args/register*constant
+  (lambda (constant ovflw?)
+    (let ((factor (abs constant)))
+      (and (or (not ovflw?) (= factor 1))
+	   (fits-in-11-bits-signed? (* (- factor 1) fixnum-1))
+	   (integer-log-base-2? factor))))
+  (lambda (tgt src constant ovflw?)
+    (guarantee-signed-fixnum constant)
+    (case constant
+      ((1)
+       (if ovflw?
+	   (LAP (COPY (TR) ,src ,tgt))
+	   (copy src tgt)))
+      ((-1)
+       (let ((skip (if ovflw? 'NSV 'NV)))
+	 (LAP (SUB (,skip) 0 ,src ,tgt))))
+      (else
+       (let* ((factor (abs constant))
+	      (xpt (integer-log-base-2? factor))
+	      (sign (standard-temporary!)))
+	 (if (or (not xpt) ovflw?)
+	     (error "fixnum-quotient: Inconsistency" constant ovflw?))
+	 (LAP ,@(if (negative? constant)
+		    (LAP (SUB (>=) 0 ,src ,tgt))
+		    (LAP (ADD (>=) 0 ,src ,tgt)))
+	      (ADDI () ,(* (-1+ factor) fixnum-1) ,tgt ,tgt)
+	      (EXTRS () ,tgt 0 1 ,sign)
+	      (SHD () ,sign ,tgt ,xpt ,tgt)
+	      (DEP () 0 31 ,scheme-type-width ,tgt)))))))
+
+(define-arithconst-method 'FIXNUM-REMAINDER
+  fixnum-methods/2-args/register*constant
+  (lambda (constant ovflw?)
+    (and (not ovflw?)
+	 (integer-log-base-2? (abs constant))))
+  (lambda (tgt src constant ovflw?)
+    (guarantee-signed-fixnum constant)
+    (case constant
+      ((1 -1)
+       (LAP (COPY () 0 ,tgt)))
+      (else
+       (let ((sign (standard-temporary!))
+	     (len (let ((xpt (integer-log-base-2? (abs constant))))
+		    (and xpt (+ xpt scheme-type-width)))))
+	 (let ((sgn-len (- 32 len)))
+	   (if (or ovflw? (not len))
+	       (error "fixnum-remainder: Inconsistency" constant ovflw?))
+	   (LAP (EXTRS () ,src 0 1 ,sign)
+		(EXTRU (=) ,src 31 ,len ,tgt)
+		(DEP () ,sign ,(- sgn-len 1) ,sgn-len ,tgt))))))))
 
 ;;;; Predicates
 
-;;; This is a kludge.  It assumes that the last instruction of the
-;;; arithmetic operation that may cause an overflow condition will
-;;; skip the following instruction if there was no overflow.  Ie., the
-;;; last instruction will conditionally nullify using NSV.  The code
-;;; for the alternative is a real kludge because we can't force the
-;;; arithmetic instruction that precedes this code to use the inverted
-;;; condition.  Hopefully the peephole optimizer will fix this if it
-;;; is ever generated.  The linearizer attempts not to use this
-;;; branch.
+;; This is a kludge.  It assumes that the last instruction of the
+;; arithmetic operation that may cause an overflow condition will skip
+;; the following instruction if there was no overflow, ie., the last
+;; instruction will nullify using NSV (or TR if overflow is
+;; impossible).  The code for the alternative is a real kludge because
+;; we can't force the arithmetic instruction that precedes this code
+;; to use the inverted condition.  Hopefully a peep-hole optimizer
+;; will fix this.  The linearizer attempts to use the "good" branch.
 
 (define-rule predicate
   (OVERFLOW-TEST)
@@ -309,17 +696,10 @@ MIT in each case. |#
 
 (define-rule predicate
   (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
-  (compare (fixnum-pred-1->cc predicate)
+  (compare (fixnum-pred->cc predicate)
 	   (standard-source! source)
 	   0))
 
-(define (fixnum-pred-1->cc predicate)
-  (case predicate
-    ((ZERO-FIXNUM?) '=)
-    ((NEGATIVE-FIXNUM?) '<)
-    ((POSITIVE-FIXNUM?) '>)
-    (else (error "unknown fixnum predicate" predicate))))
-
 (define-rule predicate
   (FIXNUM-PRED-2-ARGS (? predicate)
 		      (REGISTER (? source1))
@@ -333,7 +713,7 @@ MIT in each case. |#
 		      (REGISTER (? source))
 		      (OBJECT->FIXNUM (CONSTANT (? constant))))
   (compare-fixnum/constant*register (invert-condition-noncommutative
-				     (fixnum-pred-2->cc predicate))
+				     (fixnum-pred->cc predicate))
 				    constant
 				    (standard-source! source)))
 
@@ -341,7 +721,7 @@ MIT in each case. |#
   (FIXNUM-PRED-2-ARGS (? predicate)
 		      (OBJECT->FIXNUM (CONSTANT (? constant)))
 		      (REGISTER (? source)))
-  (compare-fixnum/constant*register (fixnum-pred-2->cc predicate)
+  (compare-fixnum/constant*register (fixnum-pred->cc predicate)
 				    constant
 				    (standard-source! source)))
 
@@ -349,9 +729,10 @@ MIT in each case. |#
   (guarantee-signed-fixnum n)
   (compare-immediate cc (* n fixnum-1) r))
 
-(define (fixnum-pred-2->cc predicate)
+(define (fixnum-pred->cc predicate)
   (case predicate
-    ((EQUAL-FIXNUM?) '=)
-    ((LESS-THAN-FIXNUM?) '<)
-    ((GREATER-THAN-FIXNUM?) '>)
-    (else (error "unknown fixnum predicate" predicate))))
\ No newline at end of file
+    ((ZERO-FIXNUM? EQUAL-FIXNUM?) '=)
+    ((NEGATIVE-FIXNUM? LESS-THAN-FIXNUM?) '<)
+    ((POSITIVE-FIXNUM? GREATER-THAN-FIXNUM?) '>)
+    (else
+     (error "fixnum-pred->cc: unknown predicate" predicate))))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/spectrum/rulrew.scm b/v7/src/compiler/machines/spectrum/rulrew.scm
index cfa443f04..c37f2da27 100644
--- a/v7/src/compiler/machines/spectrum/rulrew.scm
+++ b/v7/src/compiler/machines/spectrum/rulrew.scm
@@ -1,7 +1,7 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rulrew.scm,v 1.2 1990/04/03 04:52:59 jinx Exp $
-$MC68020-Header: rulrew.scm,v 1.2 90/04/03 04:52:22 GMT jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rulrew.scm,v 1.3 1990/07/22 18:56:39 jinx Rel $
+$MC68020-rulrew.scm,v 1.3 90/05/03 15:17:42 GMT jinx Exp $
 
 Copyright (c) 1990 Massachusetts Institute of Technology
 
@@ -34,6 +34,7 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;;; RTL Rewrite Rules
+;;; package: (compiler lap-syntaxer)
 
 (declare (usual-integrations))