From 0f7afc92f318ef7c604ae9ce75350fbcd8fad4b7 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Mon, 13 Jul 1992 03:49:21 +0000
Subject: [PATCH] Initial revision

---
 assembly/hppa/support.lisp        |   80 ++
 compiler/generic/new-genesis.lisp | 1956 +++++++++++++++++++++++++++++
 compiler/hppa/alloc.lisp          |  197 +++
 compiler/hppa/arith.lisp          |  851 +++++++++++++
 compiler/hppa/array.lisp          |  348 +++++
 compiler/hppa/c-call.lisp         |  185 +++
 compiler/hppa/call.lisp           | 1219 ++++++++++++++++++
 compiler/hppa/cell.lisp           |  273 ++++
 compiler/hppa/char.lisp           |  137 ++
 compiler/hppa/debug.lisp          |  138 ++
 compiler/hppa/float.lisp          |  588 +++++++++
 compiler/hppa/insts.lisp          | 1056 ++++++++++++++++
 compiler/hppa/macros.lisp         |  402 ++++++
 compiler/hppa/memory.lisp         |  106 ++
 compiler/hppa/move.lisp           |  309 +++++
 compiler/hppa/nlx.lisp            |  273 ++++
 compiler/hppa/parms.lisp          |  216 ++++
 compiler/hppa/pred.lisp           |   43 +
 compiler/hppa/print.lisp          |   48 +
 compiler/hppa/sap.lisp            |  286 +++++
 compiler/hppa/static-fn.lisp      |  144 +++
 compiler/hppa/subprim.lisp        |   58 +
 compiler/hppa/system.lisp         |  230 ++++
 compiler/hppa/type-vops.lisp      |  492 ++++++++
 compiler/hppa/values.lisp         |   89 ++
 compiler/hppa/vm.lisp             |  359 ++++++
 26 files changed, 10083 insertions(+)
 create mode 100644 assembly/hppa/support.lisp
 create mode 100644 compiler/generic/new-genesis.lisp
 create mode 100644 compiler/hppa/alloc.lisp
 create mode 100644 compiler/hppa/arith.lisp
 create mode 100644 compiler/hppa/array.lisp
 create mode 100644 compiler/hppa/c-call.lisp
 create mode 100644 compiler/hppa/call.lisp
 create mode 100644 compiler/hppa/cell.lisp
 create mode 100644 compiler/hppa/char.lisp
 create mode 100644 compiler/hppa/debug.lisp
 create mode 100644 compiler/hppa/float.lisp
 create mode 100644 compiler/hppa/insts.lisp
 create mode 100644 compiler/hppa/macros.lisp
 create mode 100644 compiler/hppa/memory.lisp
 create mode 100644 compiler/hppa/move.lisp
 create mode 100644 compiler/hppa/nlx.lisp
 create mode 100644 compiler/hppa/parms.lisp
 create mode 100644 compiler/hppa/pred.lisp
 create mode 100644 compiler/hppa/print.lisp
 create mode 100644 compiler/hppa/sap.lisp
 create mode 100644 compiler/hppa/static-fn.lisp
 create mode 100644 compiler/hppa/subprim.lisp
 create mode 100644 compiler/hppa/system.lisp
 create mode 100644 compiler/hppa/type-vops.lisp
 create mode 100644 compiler/hppa/values.lisp
 create mode 100644 compiler/hppa/vm.lisp

diff --git a/assembly/hppa/support.lisp b/assembly/hppa/support.lisp
new file mode 100644
index 000000000..1ed87574f
--- /dev/null
+++ b/assembly/hppa/support.lisp
@@ -0,0 +1,80 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/support.lisp,v 1.1 1992/07/13 03:49:21 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the machine specific support routines needed by
+;;; the file assembler.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "HPPA")
+
+
+(def-vm-support-routine generate-call-sequence (name style vop)
+  (ecase style
+    (:raw
+     (let ((fixup (gensym "FIXUP-")))
+       (values
+	`((let ((fixup (make-fixup ',name :assembly-routine)))
+	    (inst ldil fixup ,fixup)
+	    (inst ble fixup lisp-heap-space ,fixup :nullify t))
+	  (inst nop))
+	`((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
+		      ,fixup)))))
+    (:full-call
+     (let ((temp (make-symbol "TEMP"))
+	   (nfp-save (make-symbol "NFP-SAVE"))
+	   (lra (make-symbol "LRA")))
+       (values
+	`((let ((lra-label (gen-label))
+		(cur-nfp (current-nfp-tn ,vop)))
+	    (when cur-nfp
+	      (store-stack-tn ,nfp-save cur-nfp))
+	    (inst compute-lra-from-code code-tn lra-label ,temp ,lra)
+	    (note-this-location ,vop :call-site)
+	    (let ((fixup (make-fixup ',name :assembly-routine)))
+	      (inst ldil fixup ,temp)
+	      (inst be fixup lisp-heap-space ,temp :nullify t))
+	    (emit-return-pc lra-label)
+	    (note-this-location ,vop :single-value-return)
+	    (move ocfp-tn csp-tn)
+	    (inst compute-code-from-lra code-tn lra-label ,temp code-tn)
+	    (when cur-nfp
+	      (load-stack-tn cur-nfp ,nfp-save))))
+	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
+		      ,temp)
+	  (:temporary (:sc descriptor-reg :offset lra-offset
+			   :from (:eval 0) :to (:eval 1))
+		      ,lra)
+	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
+		      ,nfp-save)
+	  (:save-p :compute-only)))))
+    (:none
+     (let ((fixup (gensym "FIXUP-")))
+       (values
+	`((let ((fixup (make-fixup ',name :assembly-routine)))
+	    (inst ldil fixup ,fixup)
+	    (inst be fixup lisp-heap-space ,fixup :nullify t)))
+	`((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
+		      ,fixup)))))))
+
+
+(def-vm-support-routine generate-return-sequence (style)
+  (ecase style
+    (:raw
+     `((inst bv lip-tn :nullify t)))
+    (:full-call
+     `((lisp-return (make-random-tn :kind :normal
+				    :sc (sc-or-lose 'descriptor-reg)
+				    :offset lra-offset)
+		    :offset 1)))
+    (:none)))
diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp
new file mode 100644
index 000000000..fbbb384c5
--- /dev/null
+++ b/compiler/generic/new-genesis.lisp
@@ -0,0 +1,1956 @@
+;;; -*- Package: Lisp -*-
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.1 1992/07/13 03:46:45 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Core image builder for CMU Common Lisp.
+;;;
+;;; Written by Skef Wholey.  Package hackery courtesy of Rob MacLachlan.
+;;;
+;;; Completely Rewritten by William Lott for MIPS port.
+;;;
+
+(in-package "LISP")
+
+
+;;;; Representation of descriptors and spaces in the core.
+
+(defvar *dynamic* nil)
+(defparameter dynamic-space-id 1)
+
+(defvar *static* nil)
+(defparameter static-space-id 2)
+
+(defvar *read-only* nil)
+(defparameter read-only-space-id 3)
+
+(defmacro round-up (num size)
+  "Rounds number up to be an integral multiple of size."
+  (let ((size-var (gensym)))
+    `(let ((,size-var ,size))
+       (* ,size-var (ceiling ,num ,size-var)))))
+
+
+(defstruct (space
+	    (:constructor %make-space (name identifier address sap
+					    words-allocated))
+	    (:print-function %print-space))
+  name			      ; Name of this space.
+  identifier		      ; Space Identifier
+  address		      ; Word address it will be at when loaded.
+  sap			      ; System area pointer for this space.
+  words-allocated	      ; Number of words currently allocated.
+  (free-pointer 0))	      ; Word offset of next free word.
+
+(defun %print-space (space stream depth)
+  (declare (ignore depth))
+  (format stream "#<~S space (#x~X), ~S bytes used>"
+	  (space-name space)
+	  (ash (space-address space) 2)
+	  (ash (space-free-pointer space) 2)))
+
+(eval-when (compile eval load)
+
+(defconstant descriptor-low-bits 16
+  "Number of bits in the low half of the descriptor")
+
+(defconstant space-alignment (ash 1 descriptor-low-bits)
+  "Alignment requirement for spaces in the target.
+  Must be at least (ash 1 descriptor-low-bits")
+
+); eval-when
+
+(defstruct (descriptor
+	    (:constructor make-descriptor (high low &optional space offset))
+	    (:print-function %print-descriptor))
+  space			      ; The space is descriptor is allocated in.
+  offset		      ; The offset (in words) from the start of
+			      ;  that space.
+  high			      ; The high half of the descriptor.
+  low			      ; The low half of the descriptor.
+  )
+
+(defun %print-descriptor (des stream depth)
+  (declare (ignore depth))
+  (let ((lowtag (descriptor-lowtag des)))
+    (cond ((or (= lowtag vm:even-fixnum-type) (= lowtag vm:odd-fixnum-type))
+	   (let ((unsigned
+		  (logior (ash (descriptor-high des)
+			       (1+ (- descriptor-low-bits vm:lowtag-bits)))
+			  (ash (descriptor-low des) (- 1 vm:lowtag-bits)))))
+	     (if (> unsigned #x1FFFFFFF)
+		 (format stream "#<fixnum: ~D>"
+			 (- unsigned #x40000000))
+		 (format stream "#<fixnum: ~D>" unsigned))))
+	  ((or (= lowtag vm:other-immediate-0-type)
+	       (= lowtag vm:other-immediate-1-type))
+	   (format stream "#<other immediate: #x~X, type #b~8,'0B>"
+		   (logior (ash (descriptor-high des)
+				(- descriptor-low-bits vm:type-bits))
+			   (ash (descriptor-low des)
+				(- vm:type-bits)))
+		   (logand (descriptor-low des) vm:type-mask)))
+	  (t
+	   (format stream "#<pointer: #x~X, lowtag #b~3,'0B, ~A space>"
+		   (logior (ash (descriptor-high des)
+				descriptor-low-bits)
+			   (logandc2 (descriptor-low des) vm:lowtag-mask))
+		   lowtag
+		   (let ((space (descriptor-space des)))
+		     (if space
+			 (space-name space)
+			 "unknown")))))))
+
+
+(defun make-space (name identifier address
+			&optional (initial-size space-alignment))
+  (multiple-value-bind
+      (ignore remainder)
+      (truncate address space-alignment)
+    (declare (ignore ignore))
+    (unless (zerop remainder)
+      (error "The address #x~X is not aligned on a #x~X boundry."
+	     address space-alignment)))
+  (let* ((actual-size (round-up initial-size
+			       (c:backend-page-size c:*backend*)))
+	 (addr (allocate-system-memory actual-size)))
+    (%make-space name identifier
+		 (ash address (- vm:word-shift)) addr
+		 (ash actual-size (- vm:word-shift)))))
+
+(defun deallocate-space (space)
+  (deallocate-system-memory (space-sap space)
+			    (* (space-words-allocated space) vm:word-bytes)))
+
+(defun allocate-descriptor (space length lowtag)
+  "Return a descriptor for a block of LENGTH bytes out of SPACE.  The free
+  pointer is boosted as necessary.  If any additional memory is needed, we
+  vm_allocate it.  The descriptor returned is a pointer of type LOWTAG."
+  (let* ((bytes (round-up length (ash 1 vm:lowtag-bits)))
+	 (offset (space-free-pointer space))
+	 (new-free-ptr (+ offset (ash bytes (- vm:word-shift)))))
+    (when (> new-free-ptr (space-words-allocated space))
+      (do ((size (space-words-allocated space) (* 2 size)))
+	  ((>= size new-free-ptr)
+	   (setf (space-sap space)
+		 (reallocate-system-memory (space-sap space)
+					   (ash (space-words-allocated space)
+						vm:word-shift)
+					   (ash size vm:word-shift)))
+	   (setf (space-words-allocated space) size))))
+    (setf (space-free-pointer space) new-free-ptr)
+    (let ((ptr (+ (space-address space) offset)))
+      (make-descriptor (ash ptr (- vm:word-shift descriptor-low-bits))
+		       (logior (ash (logand ptr
+					    (1- (ash 1
+						     (- descriptor-low-bits
+							vm:word-shift))))
+				    vm:word-shift)
+			       lowtag)
+		       space
+		       offset))))
+
+(defun descriptor-lowtag (des)
+  "Return the lowtag bits for DES."
+  (logand (descriptor-low des) vm:lowtag-mask))
+
+(declaim (inline descriptor-bits))
+(defun descriptor-bits (des)
+  "Return the bits of DES."
+  (logior (ash (descriptor-high des) descriptor-low-bits)
+	  (descriptor-low des)))
+
+(defun descriptor-sap (des)
+  "Return a SAP pointing to the piece of memory DES refers to.  The lowtag
+  bits of DES are ignored."
+  (let ((space (descriptor-space des)))
+    (when (null space)
+      (let ((lowtag (descriptor-lowtag des))
+	    (high (descriptor-high des))
+	    (low (descriptor-low des)))
+	(when (or (eql lowtag vm:function-pointer-type)
+		  (eql lowtag vm:structure-pointer-type)
+		  (eql lowtag vm:list-pointer-type)
+		  (eql lowtag vm:other-pointer-type))
+	  (dolist (space (list *dynamic* *static* *read-only*)
+			 (error "Could not find a space for ~S" des))
+	    ;; This code relies on the fact that spaces are aligned such that
+	    ;; the descriptor-low-bits low bits are zero.
+	    (when (and (>= high (ash (space-address space)
+				     (- vm:word-shift descriptor-low-bits)))
+		       (<= high (ash (+ (space-address space)
+					(space-free-pointer space))
+				     (- vm:word-shift descriptor-low-bits))))
+	      (setf (descriptor-space des) space)
+	      (setf (descriptor-offset des)
+		    (+ (ash (- high (ash (space-address space)
+					 (- vm:word-shift descriptor-low-bits)))
+			    (- descriptor-low-bits vm:word-shift))
+		       (ash (logandc2 low vm:lowtag-mask) (- vm:word-shift))))
+	      (return)))))
+      (setf space (descriptor-space des)))
+    (unless space
+      (error "~S has no space?" des))
+    (int-sap (+ (sap-int (space-sap space))
+		(ash (descriptor-offset des) vm:word-shift)))))
+
+
+(defun make-random-descriptor (value)
+  (make-descriptor (logand (ash value (- descriptor-low-bits))
+			   (1- (ash 1 (- vm:word-bits descriptor-low-bits))))
+		   (logand value (1- (ash 1 descriptor-low-bits)))))
+
+(defun make-fixnum-descriptor (num)
+  (when (>= (integer-length num)
+	    (1+ (- vm:word-bits vm:lowtag-bits)))
+    (error "~D is too big for a fixnum." num))
+  (make-random-descriptor (ash num (1- vm:lowtag-bits))))
+
+(defun make-other-immediate-descriptor (data type)
+  (make-descriptor (ash data (- vm:type-bits descriptor-low-bits))
+		   (logior (logand (ash data (- descriptor-low-bits
+						vm:type-bits))
+				   (1- (ash 1 descriptor-low-bits)))
+			   type)))
+
+(defun make-character-descriptor (data)
+  (make-other-immediate-descriptor data vm:base-char-type))
+
+(defun descriptor-beyond (des offset type)
+  (let* ((low (logior (+ (logandc2 (descriptor-low des) vm:lowtag-mask)
+			 offset)
+		      type))
+	 (high (+ (descriptor-high des)
+		  (ash low (- descriptor-low-bits)))))
+    (make-descriptor high (logand low (1- (ash 1 descriptor-low-bits))))))
+
+
+(defun initialize-spaces ()
+  (macrolet ((frob (sym name identifier addr)
+	       `(if ,sym
+		    (setf (space-free-pointer ,sym) 0)
+		    (setf ,sym
+			  (make-space ,name ,identifier ,addr)))))
+    (frob *read-only* :read-only read-only-space-id
+      vm:target-read-only-space-start)
+    (frob *static* :static static-space-id
+      vm:target-static-space-start)
+    (frob *dynamic* :dynamic dynamic-space-id
+      vm:target-dynamic-space-start)))
+
+
+;;;; Random variables and other noise.
+
+(defparameter unbound-marker
+  (make-other-immediate-descriptor 0 vm:unbound-marker-type)
+  "Handle on the trap object.")
+
+(defvar *nil-descriptor* nil
+  "Handle on Nil.")
+
+(defvar *current-init-functions-cons* nil
+  "Head of list of functions to be called when the Lisp starts up.")
+
+(defvar *in-cold-load* nil
+  "Used by normal loader.")
+
+
+
+;;;; Stuff to read and write the core memory.
+
+(defun maybe-byte-swap (word)
+  (declare (type (unsigned-byte 32) word))
+  (assert (= vm:word-bits 32))
+  (assert (= vm:byte-bits 8))
+  (if (eq (c:backend-byte-order c:*native-backend*)
+	  (c:backend-byte-order c:*backend*))
+      word
+      (logior (ash (ldb (byte 8 0) word) 24)
+	      (ash (ldb (byte 8 8) word) 16)
+	      (ash (ldb (byte 8 16) word) 8)
+	      (ldb (byte 8 24) word))))
+
+(defun maybe-byte-swap-short (short)
+  (declare (type (unsigned-byte 16) short))
+  (assert (= vm:word-bits 32))
+  (assert (= vm:byte-bits 8))
+  (if (eq (c:backend-byte-order c:*native-backend*)
+	  (c:backend-byte-order c:*backend*))
+      short
+      (logior (ash (ldb (byte 8 0) short) 8)
+	      (ldb (byte 8 8) short))))
+  
+
+(defun write-indexed (address index value)
+  "Write VALUE (a descriptor) INDEX words from ADDRESS (also a descriptor)."
+  (if (and (null (descriptor-space value))
+	   (not (null (descriptor-offset value))))
+      (note-load-time-value-reference
+       (int-sap (+ (logandc2 (descriptor-bits address) vm:lowtag-mask)
+		   (ash index vm:word-shift)))
+       value)
+      (let ((sap (descriptor-sap address))
+	    (high (descriptor-high value))
+	    (low (descriptor-low value)))
+	(setf (sap-ref-32 sap (ash index vm:word-shift))
+	      (maybe-byte-swap (logior (ash high 16) low))))))
+
+(defun write-memory (address value)
+  "Write VALUE (a descriptor) at ADDRESS (also a descriptor)."
+  (write-indexed address 0 value))
+
+
+(defun read-indexed (address index)
+  "Return the value (as a descriptor) INDEX words from ADDRESS (a descriptor)."
+  (let* ((sap (descriptor-sap address))
+	 (value (maybe-byte-swap (sap-ref-32 sap (ash index vm:word-shift)))))
+    (make-random-descriptor value)))
+
+(defun read-memory (address)
+  "Return the value at ADDRESS (a descriptor)."
+  (read-indexed address 0))
+
+
+;;;; Allocating primitive objects.
+
+;;; There are three kinds of blocks of memory in the new type system:
+;;;
+;;;   Boxed objects (cons cells, structures, etc):
+;;; These objects have no header as all slots are descriptors.
+;;;
+;;;   Unboxed objects (bignums):
+;;; A single header words that contains the length.
+;;;
+;;;   Vector objects:
+;;; A header word with the type, a word for the length, plus the data.
+;;;
+
+(defun allocate-boxed-object (space length lowtag)
+  "Allocate LENGTH words in SPACE and return a new descriptor of type LOWTAG
+  pointing to them."
+  (allocate-descriptor space (ash length vm:word-shift) lowtag))
+
+(defun allocate-unboxed-object (space element-size length type)
+  "Allocate LENGTH units of ELEMENT-SIZE bits plus a header word in SPACE and
+  return an ``other-pointer'' descriptor to them.  Initialize the header word
+  with the resultant length and TYPE."
+  (let* ((bytes (/ (* element-size length) vm:byte-bits))
+	 (des (allocate-descriptor space
+				   (+ bytes vm:word-bytes)
+				   vm:other-pointer-type)))
+    (write-memory des
+		  (make-other-immediate-descriptor (ash bytes (- vm:word-shift))
+						   type))
+    des))
+
+(defun allocate-vector-object (space element-size length type)
+  "Allocate LENGTH units of ELEMENT-SIZE plus a header plus a length slot in
+  SPACE and return an ``other-pointer'' descriptor to them.  Initialize the
+  header word with TYPE and the length slot with LENGTH."
+  (let* ((bytes (/ (* element-size length) vm:byte-bits))
+	 (des (allocate-descriptor space (+ bytes (* 2 vm:word-bytes))
+				   vm:other-pointer-type)))
+    (write-memory des (make-other-immediate-descriptor 0 type))
+    (write-indexed des vm:vector-length-slot (make-fixnum-descriptor length))
+    des))
+
+
+
+;;;; Routines to move simple objects into the core.
+
+(defun string-to-core (string &optional (space *dynamic*))
+  "Copy string into the CORE and return a descriptor to it."
+  ;; Note: We allocate an extra byte and tweek the length back to make sure
+  ;; there will be a null at the end of the string to aid in call-out to
+  ;; C.
+  (let* ((len (length string))
+	 (des (allocate-vector-object space vm:byte-bits (1+ len)
+				      vm:simple-string-type)))
+    (write-indexed des vm:vector-length-slot (make-fixnum-descriptor len))
+    (copy-to-system-area string (* vm:vector-data-offset vm:word-bits)
+			 (descriptor-sap des)
+			 (* vm:vector-data-offset vm:word-bits)
+			 (* (1+ len) vm:byte-bits))
+    des))
+
+(defun bignum-to-core (n)
+  "Copy the bignum to the core."
+  (let* ((words (ceiling (1+ (integer-length n)) vm:word-bits))
+	 (handle (allocate-unboxed-object *dynamic* vm:word-bits
+					  words vm:bignum-type)))
+    (declare (fixnum words))
+    (do ((index 1 (1+ index))
+	 (remainder n (ash remainder (- vm:word-bits))))
+	((> index words)
+	 (unless (zerop (integer-length remainder))
+	   (warn "Wrote ~D words of ~D, but ~D was left over"
+		 words n remainder)))
+      (let ((word (ldb (byte vm:word-bits 0) remainder)))
+	(write-indexed handle index
+		       (make-descriptor (ash word (- descriptor-low-bits))
+					(ldb (byte descriptor-low-bits 0)
+					     word)))))
+    handle))
+
+(defun number-pair-to-core (first second type)
+  "Makes a number pair of TYPE (ratio or complex) and fills it in."
+  (let ((des (allocate-unboxed-object *dynamic* vm:word-bits 2 type)))
+    (write-indexed des 1 first)
+    (write-indexed des 2 second)
+    des))
+
+(defun float-to-core (num)
+  (etypecase num
+    (single-float
+     (let ((des (allocate-unboxed-object *dynamic* vm:word-bits
+					 vm:single-float-size
+					 vm:single-float-type)))
+       (write-indexed des vm:single-float-value-slot
+		      (make-random-descriptor (single-float-bits num)))
+       des))
+    (double-float
+     (let ((des (allocate-unboxed-object *dynamic* vm:word-bits
+					 vm:double-float-size
+					 vm:double-float-type))
+	   (high-bits (make-random-descriptor (double-float-high-bits num)))
+	   (low-bits (make-random-descriptor (double-float-low-bits num))))
+       (ecase (c:backend-byte-order c:*backend*)
+	 (:little-endian
+	  (write-indexed des vm:double-float-value-slot low-bits)
+	  (write-indexed des (1+ vm:double-float-value-slot) high-bits))
+	 (:big-endian
+	  (write-indexed des vm:double-float-value-slot high-bits)
+	  (write-indexed des (1+ vm:double-float-value-slot) low-bits)))
+       des))))
+
+(defun number-to-core (number)
+  "Copy the given number to the core, or flame out if we can't deal with it."
+  (typecase number
+    (integer (if (< (integer-length number) 30)
+		 (make-fixnum-descriptor number)
+		 (bignum-to-core number)))
+    (ratio (number-pair-to-core (number-to-core (numerator number))
+				(number-to-core (denominator number))
+				vm:ratio-type))
+    (complex (number-pair-to-core (number-to-core (realpart number))
+				  (number-to-core (imagpart number))
+				  vm:complex-type))
+    (float (float-to-core number))
+    (t (error "~S isn't a cold-loadable number at all!" number))))
+
+(defun sap-to-core (sap)
+  (let ((des (allocate-unboxed-object *dynamic* vm:word-bits
+				      vm:sap-size vm:sap-type)))
+    (write-indexed des vm:sap-pointer-slot
+		   (make-random-descriptor (sap-int sap)))
+    des))
+
+(defun allocate-cons (space car cdr)
+  "Allocate a cons cell in SPACE and fill it in with CAR and CDR."
+  (let ((dest (allocate-boxed-object space 2 vm:list-pointer-type)))
+    (write-memory dest car)
+    (write-indexed dest 1 cdr)
+    dest))
+
+(defmacro cold-push (thing list)
+  "Generates code to push the THING onto the given cold load LIST."
+  `(setq ,list (allocate-cons *dynamic* ,thing ,list)))
+
+
+
+;;;; Symbol magic.
+
+;;; Allocate-Symbol allocates a symbol and fills its print name cell and
+;;; property list cell.
+
+(defvar *cold-symbol-allocation-space* nil)
+
+(defun allocate-symbol (name)
+  (declare (simple-string name))
+  (let ((symbol (allocate-unboxed-object
+		 (or *cold-symbol-allocation-space* *dynamic*)
+		 vm:word-bits (1- vm:symbol-size) vm:symbol-header-type)))
+    (write-indexed symbol vm:symbol-value-slot unbound-marker)
+    (write-indexed symbol vm:symbol-plist-slot *nil-descriptor*)
+    (write-indexed symbol vm:symbol-name-slot (string-to-core name *dynamic*))
+    (write-indexed symbol vm:symbol-package-slot *nil-descriptor*)
+    symbol))
+
+(defun cold-setq (symbol value)
+  (write-indexed symbol vm:symbol-value-slot value))
+
+;;; Cold-Put  --  Internal
+;;;
+;;;    Add a property to a symbol in the core.  Assumes it doesn't exist.
+;;;
+(defun cold-put (symbol indicator value)
+  (write-indexed symbol
+		 vm:symbol-plist-slot
+		 (allocate-cons *dynamic*
+			indicator
+			(allocate-cons *dynamic*
+			       value
+			       (read-indexed symbol
+					     vm:symbol-plist-slot)))))
+
+;;;; Interning.
+
+;;;    In order to avoid having to know about the package format, we
+;;; build a data structure which we stick in *cold-packages* that
+;;; holds all interned symbols along with info about their packages.
+;;; The data structure is a list of lists in the following format:
+;;;   (<make-package-arglist>
+;;;    <internal-symbols>
+;;;    <external-symbols>
+;;;    <imported-internal-symbols>
+;;;    <imported-external-symbols>
+;;;    <shadowing-symbols>)
+;;;
+;;;    Package manipulation forms are dumped magically by the compiler
+;;; so that we can eval them at Genesis time.  An eval-for-effect fop
+;;; is used, surrounded by fops that switch the fop table to the hot
+;;; fop table and back.
+;;;
+
+;;; An alist from packages to the list of symbols in that package to be
+;;; dumped.
+
+(defvar *cold-packages* nil)
+
+;;; This holds a hash table mapping from descriptors to symbols, so we can
+;;; back up.  The key is the *address* in the target core.
+;;; 
+(defvar *cold-symbols* (make-hash-table :test #'equal))
+
+;;; Cold-Intern  --  Internal
+;;;
+;;;    Return a handle on an interned symbol.  If necessary allocate
+;;; the symbol and record which package the symbol was referenced in.
+;;; When we allocatethe symbol, make sure we record a reference to
+;;; the symbol in the home package so that the package gets set.
+;;;
+(defun cold-intern (symbol &optional (package (symbol-package symbol)))
+  (let ((cold-info (get symbol 'cold-info)))
+    (unless cold-info
+      (cond ((eq (symbol-package symbol) package)
+	     (let ((handle (allocate-symbol (symbol-name symbol))))
+	       (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
+	       (when (eq package *keyword-package*)
+		 (cold-setq handle handle))
+	       (setq cold-info
+		     (setf (get symbol 'cold-info) (cons handle nil)))))
+	    (t
+	     (cold-intern symbol)
+	     (setq cold-info (get symbol 'cold-info)))))
+    (unless (or (null package)
+		(member package (cdr cold-info) :test #'eq))
+      (push package (cdr cold-info))
+      (push symbol (cdr (or (assoc package *cold-packages* :test #'eq)
+			    (car (push (list package) *cold-packages*))))))
+    (car cold-info)))
+
+;;; Initialize-Symbols  --  Internal
+;;;
+;;;    Since the initial symbols must be allocated before we can intern
+;;; anything else, we intern those here.  We also set the values of T and Nil.
+;;;
+(defun initialize-symbols ()
+  "Initilizes the cold load symbol-hacking data structures."
+  (do-all-symbols (sym)
+    (remprop sym 'cold-info))
+  (setq *cold-packages* nil)
+  (let ((*cold-symbol-allocation-space* *static*))
+    ;; Special case NIL.
+    (let ((des (allocate-unboxed-object *static* vm:word-bits
+					vm:symbol-size 0)))
+      (setf *nil-descriptor*
+	    (make-descriptor (descriptor-high des)
+			     (+ (descriptor-low des) (* 2 vm:word-bytes)
+			        (- vm:list-pointer-type
+				   vm:other-pointer-type))))
+      (write-indexed des 1
+		     (make-other-immediate-descriptor 0 vm:symbol-header-type))
+      (write-indexed des (1+ vm:symbol-value-slot) *nil-descriptor*)
+      (write-indexed des (+ vm:symbol-value-slot 2) *nil-descriptor*)
+      (write-indexed des (1+ vm:symbol-plist-slot) *nil-descriptor*)
+      (write-indexed des (1+ vm:symbol-name-slot)
+		     (string-to-core "NIL" *dynamic*))
+      (write-indexed des (1+ vm:symbol-package-slot) *nil-descriptor*)
+      (setf (get nil 'cold-info) (cons *nil-descriptor* nil))
+      (cold-intern nil))
+
+    ;; Intern the others.
+    (dolist (symbol vm:static-symbols)
+      (let ((des (cold-intern symbol)))
+	(unless (= (- (descriptor-low des) (descriptor-low *nil-descriptor*))
+		   (vm:static-symbol-offset symbol))
+	  (warn "Offset from ~S to ~S is ~D, not ~D"
+		symbol
+		nil
+		(- (descriptor-low des) (descriptor-low *nil-descriptor*))
+		(vm:static-symbol-offset symbol)))))
+
+    ;; Establish the value of T.
+    (let ((t-symbol (cold-intern t)))
+      (cold-setq t-symbol t-symbol))))
+
+;;; Finish-Symbols  --  Internal
+;;;
+;;;    Establish initial values for magic symbols.
+;;; 
+;;;    Scan over all the symbols referenced in each package in *cold-packages*
+;;; making the apropriate entry in the *initial-symbols* data structure to
+;;; intern the thing.
+;;;
+(defun finish-symbols ()
+  (macrolet ((frob (symbol)
+	       `(cold-setq (cold-intern ',symbol)
+			   (cold-fdefinition-object (cold-intern ',symbol)))))
+    (frob lisp::%initial-function)
+    (frob lisp::maybe-gc)
+    (frob kernel::internal-error)
+    (frob di::handle-breakpoint)
+    (frob lisp::fdefinition-object))
+  (macrolet ((frob (symbol value)
+	       `(cold-setq (cold-intern ',symbol) ,value)))
+    (frob *current-catch-block* (make-fixnum-descriptor 0))
+    (frob *current-unwind-protect-block* (make-fixnum-descriptor 0))
+    (frob *eval-stack-top* (make-fixnum-descriptor 0))
+
+    (frob *free-interrupt-context-index* (make-fixnum-descriptor 0))
+
+    (let ((res *nil-descriptor*))
+      (dolist (cpkg *cold-packages*)
+	(let* ((pkg (car cpkg))
+	       (shadows (package-shadowing-symbols pkg)))
+	  (let ((internal *nil-descriptor*)
+		(external *nil-descriptor*)
+		(imported-internal *nil-descriptor*)
+		(imported-external *nil-descriptor*)
+		(shadowing *nil-descriptor*))
+	    (dolist (sym (cdr cpkg))
+	      (let ((handle (car (get sym 'cold-info))))
+		(multiple-value-bind (found where)
+				     (find-symbol (symbol-name sym) pkg)
+		  (unless (and where (eq found sym))
+		    (error "Symbol ~S is not available in ~S." sym pkg))
+		  (when (memq sym shadows)
+		    (cold-push handle shadowing))
+		  (case where
+		    (:internal
+		     (if (eq (symbol-package sym) pkg)
+			 (cold-push handle internal)
+			 (cold-push handle imported-internal)))
+		    (:external
+		     (if (eq (symbol-package sym) pkg)
+			 (cold-push handle external)
+			 (cold-push handle imported-external)))))))
+	    (let ((r *nil-descriptor*))
+	      (cold-push shadowing r)
+	      (cold-push imported-external r)
+	      (cold-push imported-internal r)
+	      (cold-push external r)
+	      (cold-push internal r)
+	      (cold-push (make-make-package-args pkg) r)
+	      (cold-push r res)))))
+      
+      (frob *initial-symbols* res))
+
+    (frob *initial-fdefn-objects* (list-all-fdefn-objects))
+
+    (frob *lisp-initialization-functions* *current-init-functions-cons*)
+
+    
+
+    ;; Nothing should be allocated after this.
+    ;;
+    (frob *read-only-space-free-pointer*
+      (allocate-descriptor *read-only* 0 vm:even-fixnum-type))
+    (frob *static-space-free-pointer*
+      (allocate-descriptor *static* 0 vm:even-fixnum-type))
+    (frob *initial-dynamic-space-free-pointer*
+      (allocate-descriptor *dynamic* 0 vm:even-fixnum-type))))
+
+;;; Make-Make-Package-Args  --  Internal
+;;;
+;;;    Make a cold list that can be used as the arglist to make-package to
+;;; make a similar package.
+;;;
+(defun make-make-package-args (package)
+  (let* ((use *nil-descriptor*)
+	 (nicknames *nil-descriptor*)
+	 (res *nil-descriptor*))
+    (dolist (u (package-use-list package))
+      (when (assoc u *cold-packages*)
+	(cold-push (string-to-core (package-name u)) use)))
+    (dolist (n (package-nicknames package))
+      (cold-push (string-to-core n) nicknames))
+    (cold-push (number-to-core (truncate (internal-symbol-count package) 0.8))
+	       res)
+    (cold-push (cold-intern :internal-symbols) res)
+    (cold-push (number-to-core (truncate (external-symbol-count package) 0.8))
+	       res)
+    (cold-push (cold-intern :external-symbols) res)
+
+    (cold-push nicknames res)
+    (cold-push (cold-intern :nicknames) res)
+
+    (cold-push use res)
+    (cold-push (cold-intern :use) res)
+    
+    (cold-push (string-to-core (package-name package)) res)
+    res))
+
+
+
+;;;; Fdefinition objects.
+
+(defvar *fdefn-objects* (make-hash-table :test #'equal))
+
+(defvar *fdefn-space* nil)
+
+(defun extract-fdefn-name (des)
+  (ecase (descriptor-lowtag des)
+    (#.vm:list-pointer-type
+     (if (= (descriptor-bits des) (descriptor-bits *nil-descriptor*))
+	 nil
+	 (cons (extract-fdefn-name (read-indexed des vm:cons-car-slot))
+	       (extract-fdefn-name (read-indexed des vm:cons-cdr-slot)))))
+    (#.vm:other-pointer-type
+     (or (gethash (descriptor-bits des) *cold-symbols*)
+	 (descriptor-bits des)))))
+
+(defun cold-fdefinition-object (name &optional leave-fn-raw)
+  (let ((hash (extract-fdefn-name name)))
+    (or (gethash hash *fdefn-objects*)
+	(let ((fdefn (allocate-boxed-object (or *fdefn-space* *dynamic*)
+					    (1- vm:fdefn-size)
+					    vm:other-pointer-type)))
+	  (setf (gethash hash *fdefn-objects*) fdefn)
+	  (write-memory fdefn (make-other-immediate-descriptor
+			       (1- vm:fdefn-size) vm:fdefn-type))
+	  (write-indexed fdefn vm:fdefn-name-slot name)
+	  (unless leave-fn-raw
+	    (write-indexed fdefn vm:fdefn-function-slot *nil-descriptor*)
+	    (write-indexed fdefn vm:fdefn-raw-addr-slot
+			   (make-random-descriptor
+			    (ecase (c:backend-fasl-file-implementation
+				    c:*backend*)
+			      ((#.c:pmax-fasl-file-implementation
+				#.c:rt-fasl-file-implementation
+				#.c:rt-afpa-fasl-file-implementation
+				#.c:x86-fasl-file-implementation
+				#.c:hppa-fasl-file-implementation)
+			       (lookup-foreign-symbol "undefined_tramp"))
+			      (#.c:sparc-fasl-file-implementation
+			       (lookup-foreign-symbol "_undefined_tramp"))))))
+	  fdefn))))
+  
+(defun cold-fset (name defn)
+  (let ((fdefn (cold-fdefinition-object name t))
+	(type (logand (descriptor-low (read-memory defn)) vm:type-mask)))
+    (write-indexed fdefn vm:fdefn-function-slot defn)
+    (write-indexed fdefn vm:fdefn-raw-addr-slot
+		   (ecase (c:backend-fasl-file-implementation c:*backend*)
+		     ((#.c:pmax-fasl-file-implementation
+		       #.c:rt-fasl-file-implementation
+		       #.c:rt-afpa-fasl-file-implementation
+		       #.c:x86-fasl-file-implementation
+		       #.c:hppa-fasl-file-implementation)
+		      (ecase type
+			(#.vm:function-header-type
+			 (make-random-descriptor
+			  (+ (logandc2 (descriptor-bits defn) vm:lowtag-mask)
+			     (ash vm:function-header-code-offset
+				  vm:word-shift))))
+			(#.vm:closure-header-type
+			 (make-random-descriptor
+			  (lookup-foreign-symbol "closure_tramp")))))
+		     (#.c:sparc-fasl-file-implementation
+		      (ecase type
+			(#.vm:function-header-type defn)
+			(#.vm:closure-header-type
+			 (make-random-descriptor
+			  (lookup-foreign-symbol "_closure_tramp")))))))
+    fdefn))
+
+(defun initialize-static-fns ()
+  (let ((*fdefn-space* *static*))
+    (dolist (sym vm:static-functions)
+      (let* ((fdefn (cold-fdefinition-object (cold-intern sym)))
+	     (offset (- (+ (- (descriptor-low fdefn)
+			      vm:other-pointer-type)
+			   (* vm:fdefn-raw-addr-slot vm:word-bytes))
+			(descriptor-low *nil-descriptor*)))
+	     (desired (vm:static-function-offset sym)))
+	(unless (= offset desired)
+	  (warn "Offset from FDEFN ~S to ~S is ~D, not ~D"
+		sym nil offset desired))))))
+
+(defun list-all-fdefn-objects ()
+  (let ((result *nil-descriptor*))
+    (maphash #'(lambda (key value)
+		 (declare (ignore key))
+		 (cold-push value result))
+	     *fdefn-objects*)
+    result))
+
+
+
+;;;; Reading FASL files.
+
+(defvar *cold-fop-functions* (replace (make-array 256) fop-functions)
+  "FOP functions for cold loading.")
+
+(defvar *normal-fop-functions*)
+
+;;; Define-Cold-FOP  --  Internal
+;;;
+;;;    Like Define-FOP in load, but looks up the code, and stores into
+;;; the *cold-fop-functions* vector.
+;;;
+(defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
+  (let ((fname (concat-pnames 'cold- name))
+	(code (get name 'fop-code)))
+    `(progn
+       (defun ,fname ()
+	 ,@(if (eq pushp :nope)
+	       forms
+	       `((with-fop-stack ,pushp ,@forms))))
+       ,@(if code
+	     `((setf (svref *cold-fop-functions* ,code) #',fname))
+	     (warn "~S is not a defined FOP." name)))))
+
+;;; Clone-Cold-FOP  --  Internal
+;;;
+;;;    Clone a couple of cold fops.
+;;;
+(defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
+  `(progn
+    (macrolet ((clone-arg () '(read-arg 4)))
+      (define-cold-fop (,name ,pushp) ,@forms))
+    (macrolet ((clone-arg () '(read-arg 1)))
+      (define-cold-fop (,small-name ,pushp) ,@forms))))
+
+;;; Not-Cold-Fop  --  Internal
+;;;
+;;;    Define a fop to be undefined in cold load.
+;;;
+(defmacro not-cold-fop (name)
+  `(define-cold-fop (,name)
+     (error "~S is not supported in cold load." ',name)))
+
+;;;; Random cold fops...
+
+(define-cold-fop (fop-misc-trap) unbound-marker)
+
+(define-cold-fop (fop-character)
+  (make-character-descriptor (read-arg 3)))
+(define-cold-fop (fop-short-character)
+  (make-character-descriptor (read-arg 1)))
+
+(define-cold-fop (fop-empty-list) *nil-descriptor*)
+(define-cold-fop (fop-truth) (cold-intern t))
+
+(define-cold-fop (fop-normal-load :nope)
+  (setq fop-functions *normal-fop-functions*))
+
+(define-fop (fop-maybe-cold-load 82 :nope)
+  (when *in-cold-load*
+    (setq fop-functions *cold-fop-functions*)))
+
+(define-cold-fop (fop-maybe-cold-load :nope))
+
+(clone-cold-fop (fop-struct)
+		(fop-small-struct)
+  (let* ((size (clone-arg))
+	 (result (allocate-boxed-object *dynamic* (1+ size)
+					vm:structure-pointer-type)))
+    (write-memory result (make-other-immediate-descriptor
+			  size vm:structure-header-type))
+    (do ((index (1- size) (1- index)))
+	((minusp index))
+      (declare (fixnum index))
+      (write-indexed result (+ index vm:structure-slots-offset) (pop-stack)))
+    result))
+
+
+;;; Loading symbols...
+
+;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns
+;;; that symbol in the given Package.
+;;;
+(defun cold-load-symbol (size package)
+  (let ((string (make-string size)))
+    (read-n-bytes *fasl-file* string 0 size)
+    (cold-intern (intern string package) package)))
+
+(clone-cold-fop (fop-symbol-save)
+		(fop-small-symbol-save)
+  (push-table (cold-load-symbol (clone-arg) *package*)))
+
+(macrolet ((frob (name pname-len package-len)
+	     `(define-cold-fop (,name)
+		(let ((index (read-arg ,package-len)))
+		  (push-table
+		   (cold-load-symbol (read-arg ,pname-len)
+				     (svref *current-fop-table* index)))))))
+  (frob fop-symbol-in-package-save 4 4)
+  (frob fop-small-symbol-in-package-save 1 4)
+  (frob fop-symbol-in-byte-package-save 4 1)
+  (frob fop-small-symbol-in-byte-package-save 1 1))
+
+(clone-cold-fop (fop-lisp-symbol-save)
+		(fop-lisp-small-symbol-save)
+  (push-table (cold-load-symbol (clone-arg) *lisp-package*)))
+
+(clone-cold-fop (fop-keyword-symbol-save)
+		(fop-keyword-small-symbol-save)
+  (push-table (cold-load-symbol (clone-arg) *keyword-package*)))
+
+(clone-cold-fop (fop-uninterned-symbol-save)
+		(fop-uninterned-small-symbol-save)
+  (let* ((size (clone-arg))
+	 (name (make-string size)))
+    (read-n-bytes *fasl-file* name 0 size)
+    (let ((symbol (allocate-symbol name)))
+      (push-table symbol))))
+
+;;; Loading lists...
+
+;;; Cold-Stack-List makes a list of the top Length things on the Fop-Stack.
+;;; The last cdr of the list is set to Last.
+
+(defmacro cold-stack-list (length last)
+  `(do* ((index ,length (1- index))
+	 (result ,last (allocate-cons *dynamic* (pop-stack) result)))
+	((= index 0) result)
+     (declare (fixnum index))))
+
+(define-cold-fop (fop-list)
+  (cold-stack-list (read-arg 1) *nil-descriptor*))
+(define-cold-fop (fop-list*)
+  (cold-stack-list (read-arg 1) (pop-stack)))
+(define-cold-fop (fop-list-1)
+  (cold-stack-list 1 *nil-descriptor*))
+(define-cold-fop (fop-list-2)
+  (cold-stack-list 2 *nil-descriptor*))
+(define-cold-fop (fop-list-3)
+  (cold-stack-list 3 *nil-descriptor*))
+(define-cold-fop (fop-list-4)
+  (cold-stack-list 4 *nil-descriptor*))
+(define-cold-fop (fop-list-5)
+  (cold-stack-list 5 *nil-descriptor*))
+(define-cold-fop (fop-list-6)
+  (cold-stack-list 6 *nil-descriptor*))
+(define-cold-fop (fop-list-7)
+  (cold-stack-list 7 *nil-descriptor*))
+(define-cold-fop (fop-list-8)
+  (cold-stack-list 8 *nil-descriptor*))
+(define-cold-fop (fop-list*-1)
+  (cold-stack-list 1 (pop-stack)))
+(define-cold-fop (fop-list*-2)
+  (cold-stack-list 2 (pop-stack)))
+(define-cold-fop (fop-list*-3)
+  (cold-stack-list 3 (pop-stack)))
+(define-cold-fop (fop-list*-4)
+  (cold-stack-list 4 (pop-stack)))
+(define-cold-fop (fop-list*-5)
+  (cold-stack-list 5 (pop-stack)))
+(define-cold-fop (fop-list*-6)
+  (cold-stack-list 6 (pop-stack)))
+(define-cold-fop (fop-list*-7)
+  (cold-stack-list 7 (pop-stack)))
+(define-cold-fop (fop-list*-8)
+  (cold-stack-list 8 (pop-stack)))
+
+;;; Loading vectors...
+
+(clone-cold-fop (fop-string)
+		(fop-small-string)
+  (let* ((len (clone-arg))
+	 (string (make-string len)))
+    (read-n-bytes *fasl-file* string 0 len)
+    (string-to-core string)))
+
+(clone-cold-fop (fop-vector)
+		(fop-small-vector)
+  (let* ((size (clone-arg))
+	 (result (allocate-vector-object *dynamic* vm:word-bits size
+					 vm:simple-vector-type)))
+    (do ((index (1- size) (1- index)))
+	((minusp index))
+      (declare (fixnum index))
+      (write-indexed result (+ index vm:vector-data-offset) (pop-stack)))
+    result))
+
+(clone-cold-fop (fop-uniform-vector)
+		(fop-small-uniform-vector)
+  (let* ((size (clone-arg))
+	 (datum (pop-stack))
+	 (result (allocate-vector-object *dynamic* vm:word-bits size
+					 vm:simple-vector-type)))
+    (do ((index (1- size) (1- index)))
+	((minusp index))
+      (declare (fixnum index))
+      (write-indexed result (+ index vm:vector-data-offset) datum))
+    result))
+
+(define-cold-fop (fop-uniform-int-vector)
+  (let* ((len (read-arg 4))
+	 (size (read-arg 1))
+	 (type (case size
+		 (1 vm:simple-bit-vector-type)
+		 (2 vm:simple-array-unsigned-byte-2-type)
+		 (4 vm:simple-array-unsigned-byte-4-type)
+		 (8 vm:simple-array-unsigned-byte-8-type)
+		 (16 vm:simple-array-unsigned-byte-16-type)
+		 (32 vm:simple-array-unsigned-byte-32-type)
+		 (t (error "Losing element size: ~D." size))))
+	 (value (case size
+		  ((1 2 4 8)
+		   (read-arg 1))
+		  (16
+		   (read-arg 2))
+		  (32
+		   (read-arg 4))))
+	 (result (allocate-vector-object *dynamic* size len type)))
+    (do ((bits size (* bits 2))
+	 (word value (logior word (ash word bits))))
+	((= size vm:word-bits)
+	 (let ((datum (make-random-descriptor word)))
+	   (dotimes (index (ceiling (* len size) vm:word-bits))
+	     (write-indexed result (+ index vm:vector-data-offset) datum)))))
+    result))
+
+(define-cold-fop (fop-int-vector)
+  (let* ((len (read-arg 4))
+	 (size (read-arg 1))
+	 (type (case size
+		 (1 vm:simple-bit-vector-type)
+		 (2 vm:simple-array-unsigned-byte-2-type)
+		 (4 vm:simple-array-unsigned-byte-4-type)
+		 (8 vm:simple-array-unsigned-byte-8-type)
+		 (16 vm:simple-array-unsigned-byte-16-type)
+		 (32 vm:simple-array-unsigned-byte-32-type)
+		 (t (error "Losing element size: ~D." size))))
+	 (result (allocate-vector-object *dynamic* size len type)))
+    (unless (zerop len)
+      (read-n-bytes *fasl-file*
+		    (descriptor-sap result)
+		    (ash vm:vector-data-offset vm:word-shift)
+		    (ceiling (* len size) vm:byte-bits)))
+    result))
+
+(define-cold-fop (fop-single-float-vector)
+  (let* ((len (read-arg 4))
+	 (result (allocate-vector-object *dynamic* vm:word-bits len
+					 vm:simple-array-single-float-type)))
+    (unless (zerop len)
+      (read-n-bytes *fasl-file*
+		    (descriptor-sap result)
+		    (ash vm:vector-data-offset vm:word-shift)
+		    (* len vm:word-bytes)))
+    result))
+
+(define-cold-fop (fop-double-float-vector)
+  (let* ((len (read-arg 4))
+	 (result (allocate-vector-object *dynamic* (* vm:word-bits 2) len
+					 vm:simple-array-double-float-type)))
+    (unless (zerop len)
+      (read-n-bytes *fasl-file*
+		    (descriptor-sap result)
+		    (ash vm:vector-data-offset vm:word-shift)
+		    (* len vm:word-bytes 2)))
+    result))
+
+(define-cold-fop (fop-array)
+  (let* ((rank (read-arg 4))
+	 (data-vector (pop-stack))
+	 (result (allocate-boxed-object *dynamic*
+					(+ vm:array-dimensions-offset rank)
+					vm:other-pointer-type)))
+    (write-memory result
+		  (make-other-immediate-descriptor rank vm:simple-array-type))
+    (write-indexed result vm:array-fill-pointer-slot *nil-descriptor*)
+    (write-indexed result vm:array-data-slot data-vector)
+    (write-indexed result vm:array-displacement-slot *nil-descriptor*)
+    (write-indexed result vm:array-displaced-p-slot *nil-descriptor*)
+    (let ((total-elements 1))
+      (dotimes (axis rank)
+	(let ((dim (pop-stack)))
+	  (unless (or (= (descriptor-lowtag dim) vm:even-fixnum-type)
+		      (= (descriptor-lowtag dim) vm:odd-fixnum-type))
+	    (error "Non-fixnum dimension? (~S)" dim))
+	  (setf total-elements
+		(* total-elements
+		   (logior (ash (descriptor-high dim)
+				(- descriptor-low-bits (1- vm:lowtag-bits)))
+			   (ash (descriptor-low dim)
+				(- 1 vm:lowtag-bits)))))
+	  (write-indexed result (+ vm:array-dimensions-offset axis) dim)))
+      (write-indexed result vm:array-elements-slot
+		     (make-fixnum-descriptor total-elements)))
+    result))
+
+;;; Loading numbers.
+
+(defmacro cold-number (fop)
+  `(define-cold-fop (,fop :nope)
+     (,fop)
+     (with-fop-stack t
+       (number-to-core (pop-stack)))))
+
+(cold-number fop-single-float)
+(cold-number fop-double-float)
+(cold-number fop-integer)
+(cold-number fop-small-integer)
+(cold-number fop-word-integer)
+(cold-number fop-byte-integer)
+
+(define-cold-fop (fop-ratio)
+  (let ((den (pop-stack)))
+    (number-pair-to-core (pop-stack) den vm:ratio-type)))
+
+(define-cold-fop (fop-complex)
+  (let ((im (pop-stack)))
+    (number-pair-to-core (pop-stack) im vm:complex-type)))
+
+
+;;; Calling (or not calling).
+
+(not-cold-fop fop-eval)
+(not-cold-fop fop-eval-for-effect)
+
+
+(defvar *load-time-value-counter*)
+
+(define-cold-fop (fop-funcall)
+  (unless (= (read-arg 1) 0)
+    (error "Can't FOP-FUNCALL random stuff in cold load."))
+  (let ((counter *load-time-value-counter*))
+    (cold-push (allocate-cons
+		*dynamic*
+		(cold-intern :load-time-value)
+		(allocate-cons
+		 *dynamic*
+		 (pop-stack)
+		 (allocate-cons
+		  *dynamic*
+		  (number-to-core counter)
+		  *nil-descriptor*)))
+	       *current-init-functions-cons*)
+    (setf *load-time-value-counter* (1+ counter))
+    (make-descriptor 0 0 nil counter)))
+
+(defun note-load-time-value-reference (address marker)
+  (cold-push (allocate-cons
+	      *dynamic*
+	      (cold-intern :load-time-value-fixup)
+	      (allocate-cons
+	       *dynamic*
+	       (sap-to-core address)
+	       (allocate-cons
+		*dynamic*
+		(number-to-core (descriptor-offset marker))
+		*nil-descriptor*)))
+	     *current-init-functions-cons*))
+
+(defun finalize-load-time-value-noise ()
+  (cold-setq (cold-intern 'lisp::*load-time-values*)
+	     (allocate-vector-object *dynamic* vm:word-bits
+				     *load-time-value-counter*
+				     vm:simple-vector-type)))
+
+(define-cold-fop (fop-funcall-for-effect nil)
+  (if (= (read-arg 1) 0)
+      (cold-push (pop-stack) *current-init-functions-cons*)
+      (error "Can't FOP-FUNCALL random stuff in cold load.")))
+
+
+;;;; Fixing up circularities.
+
+(define-cold-fop (fop-rplaca nil)
+  (let ((obj (svref *current-fop-table* (read-arg 4)))
+	(idx (read-arg 4)))
+    (write-memory (cold-nthcdr idx obj) (pop-stack))))
+
+(define-cold-fop (fop-rplacd nil)
+  (let ((obj (svref *current-fop-table* (read-arg 4)))
+	(idx (read-arg 4)))
+    (write-indexed (cold-nthcdr idx obj) 1 (pop-stack))))
+
+(define-cold-fop (fop-svset nil)
+  (let ((obj (svref *current-fop-table* (read-arg 4)))
+	(idx (read-arg 4)))
+    (write-indexed obj
+		   (+ idx
+		      (ecase (descriptor-lowtag obj)
+			(#.vm:structure-pointer-type 1)
+			(#.vm:other-pointer-type 2)))
+		   (pop-stack))))
+
+(define-cold-fop (fop-structset nil)
+  (let ((obj (svref *current-fop-table* (read-arg 4)))
+	(idx (read-arg 4)))
+    (write-indexed obj (1+ idx) (pop-stack))))
+
+(define-cold-fop (fop-nthcdr t)
+  (cold-nthcdr (read-arg 4) (pop-stack)))
+
+
+(defun cold-nthcdr (index obj)
+  (dotimes (i index)
+    (setq obj (read-indexed obj 1)))
+  obj)
+
+
+;;; Loading code objects and functions.
+
+(define-cold-fop (fop-fset nil)
+  (let ((fn (pop-stack))
+	(name (pop-stack)))
+    (cold-fset name fn)))
+
+(define-cold-fop (fop-fdefinition)
+  (cold-fdefinition-object (pop-stack)))
+
+
+(defun cold-verify-code-format ()
+  (unless *current-code-format*
+    (error "Can't load code until after FOP-CODE-FORMAT."))
+  (let ((implementation (car *current-code-format*))
+	(version (cdr *current-code-format*)))
+    (unless (= implementation (c:backend-fasl-file-implementation c:*backend*))
+      (error
+       "~A was compiled for a ~A, but we are trying to build a core for a ~A"
+       *Fasl-file*
+       (or (elt c:fasl-file-implementations implementation)
+	   "unknown machine")
+       (or (elt c:fasl-file-implementations
+		(c:backend-fasl-file-implementation c:*backend*))
+	   "unknown machine")))
+    (unless (= version (c:backend-fasl-file-version c:*backend*))
+      (error
+       "~A was compiled for a fasl-file version ~A, but we need version ~A"
+       *Fasl-file* version (c:backend-fasl-file-version c:*backend*)))))
+
+(defmacro define-cold-code-fop (name nconst size)
+  `(define-cold-fop (,name)
+     (cold-verify-code-format)
+     (let* ((nconst ,nconst)
+	    (size ,size)
+	    (header-size
+	     ;; Note: we round the number of constants up to assure that
+	     ;; the code vector will be properly aligned.
+	     (round-up (+ vm:code-trace-table-offset-slot nconst) 2))
+	    (des (allocate-descriptor *dynamic*
+				      (+ (ash header-size vm:word-shift) size)
+				      vm:other-pointer-type)))
+       (write-memory des
+		     (make-other-immediate-descriptor header-size
+						      vm:code-header-type))
+       (write-indexed des vm:code-code-size-slot
+		      (make-fixnum-descriptor
+		       (ash (+ size (1- (ash 1 vm:word-shift)))
+			    (- vm:word-shift))))
+       (write-indexed des vm:code-entry-points-slot *nil-descriptor*)
+       (write-indexed des vm:code-debug-info-slot (pop-stack))
+       (do ((index (+ nconst (1- vm:code-trace-table-offset-slot))
+		   (1- index)))
+	   ((< index vm:code-trace-table-offset-slot))
+	 (write-indexed des index (pop-stack)))
+       (read-n-bytes *fasl-file*
+		     (descriptor-sap des)
+		     (ash header-size vm:word-shift)
+		     size)
+       des)))  
+
+(define-cold-code-fop fop-code (read-arg 4) (read-arg 4))
+
+(define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2))
+
+
+(clone-cold-fop (fop-alter-code nil)
+		(fop-byte-alter-code)
+  (let ((slot (clone-arg))
+	(value (pop-stack))
+	(code (pop-stack)))
+    (write-indexed code slot value)))
+
+(defun calc-offset (code-object after-header)
+  (let ((header (read-memory code-object)))
+    (+ after-header
+       (ash (logior (ash (descriptor-high header)
+			 (- descriptor-low-bits vm:type-bits))
+		    (ash (descriptor-low header)
+			 (- vm:type-bits)))
+	    vm:word-shift))))
+
+(define-cold-fop (fop-function-entry)
+  (let* ((type (pop-stack))
+	 (arglist (pop-stack))
+	 (name (pop-stack))
+	 (code-object (pop-stack))
+	 (offset (calc-offset code-object (read-arg 4)))
+	 (fn (descriptor-beyond code-object offset vm:function-pointer-type))
+	 (next (read-indexed code-object vm:code-entry-points-slot)))
+    (unless (zerop (logand offset vm:lowtag-mask))
+      (warn "Unaligned function entry: ~S at #x~X" name offset))
+    (write-indexed code-object vm:code-entry-points-slot fn)
+    (write-memory fn (make-other-immediate-descriptor (ash offset
+							   (- vm:word-shift))
+						      vm:function-header-type))
+    (write-indexed fn vm:function-header-self-slot
+		   (if (= (c:backend-fasl-file-implementation c:*backend*)
+			  #.c:x86-fasl-file-implementation)
+		       (make-random-descriptor
+			(+ (descriptor-bits fn)
+			   (- (ash vm:function-header-code-offset
+				   vm:word-shift)
+			      vm:function-pointer-type)))
+		       fn))
+    (write-indexed fn vm:function-header-next-slot next)
+    (write-indexed fn vm:function-header-name-slot name)
+    (write-indexed fn vm:function-header-arglist-slot arglist)
+    (write-indexed fn vm:function-header-type-slot type)
+    fn))
+
+(define-cold-fop (fop-foreign-fixup)
+  (let* ((kind (pop-stack))
+	 (code-object (pop-stack))
+	 (len (read-arg 1))
+	 (sym (make-string len)))
+    (read-n-bytes *fasl-file* sym 0 len)
+    (let ((offset (calc-offset code-object (read-arg 4))))
+      (do-cold-fixup code-object offset (lookup-foreign-symbol sym) kind))
+    code-object))
+
+(define-cold-fop (fop-assembler-code)
+  (cold-verify-code-format)
+  (let* ((length (read-arg 4))
+	 (header-size
+	  ;; Note: we round the number of constants up to assure that
+	  ;; the code vector will be properly aligned.
+	  (round-up vm:code-constants-offset 2))
+	 (des (allocate-descriptor *read-only*
+				   (+ (ash header-size vm:word-shift) length)
+				   vm:other-pointer-type)))
+    (write-memory des
+		  (make-other-immediate-descriptor header-size
+						   vm:code-header-type))
+    (write-indexed des vm:code-code-size-slot
+		   (make-fixnum-descriptor
+		    (ash (+ length (1- (ash 1 vm:word-shift)))
+			 (- vm:word-shift))))
+    (write-indexed des vm:code-entry-points-slot *nil-descriptor*)
+    (write-indexed des vm:code-debug-info-slot *nil-descriptor*)
+
+    (read-n-bytes *fasl-file*
+		  (descriptor-sap des)
+		  (ash header-size vm:word-shift)
+		  length)
+    des))
+
+(define-cold-fop (fop-assembler-routine)
+  (let* ((routine (pop-stack))
+	 (des (pop-stack))
+	 (offset (calc-offset des (read-arg 4))))
+    (record-cold-assembler-routine
+     routine
+     (+ (logandc2 (descriptor-bits des) vm:lowtag-mask) offset))
+    des))
+
+(define-cold-fop (fop-assembler-fixup)
+  (let* ((routine (pop-stack))
+	 (kind (pop-stack))
+	 (code-object (pop-stack))
+	 (offset (calc-offset code-object (read-arg 4))))
+    (record-cold-assembler-fixup routine code-object offset kind)
+    code-object))
+
+(define-cold-fop (fop-code-object-fixup)
+  (let* ((kind (pop-stack))
+	 (code-object (pop-stack))
+	 (offset (calc-offset code-object (read-arg 4))))
+    (do-cold-fixup code-object offset
+		   (descriptor-bits code-object)
+		   kind)
+    code-object))
+
+
+;;; Cold-Load loads stuff into the core image being built by rebinding
+;;; the Fop-Functions table to a table of cold loading functions.
+
+(defun cold-load (filename)
+  "Loads the file named by FileName into the cold load image being built."
+  (let* ((*normal-fop-functions* fop-functions)
+	 (fop-functions *cold-fop-functions*)
+	 (*in-cold-load* t))
+    (with-open-file (file (merge-pathnames
+			   filename
+			   (make-pathname
+			    :type (c:backend-fasl-file-type c:*backend*)))
+			  :element-type '(unsigned-byte 8))
+      (load file :verbose nil))))
+
+
+
+;;;; Fixups and related stuff.
+
+(defvar *cold-foreign-symbol-table*
+  (make-hash-table :test 'equal))
+
+(defun init-foreign-symbol-table ()
+  (clrhash *cold-foreign-symbol-table*))
+
+(defun load-foreign-symbol-table (filename)
+  (with-open-file (file filename)
+    (let* ((version-line (read-line file))
+	   (last-space (position #\Space version-line :from-end t))
+	   (version (parse-integer version-line :start (1+ last-space))))
+      (loop
+	(let ((line (read-line file nil nil)))
+	  (unless line
+	    (return))
+	  (multiple-value-bind
+	      (value name)
+	      (if (string= "0x" line :end2 2)
+		  (values (parse-integer line :start 2 :end 10 :radix 16)
+			  (subseq line 13))
+		  (values (parse-integer line :end 8 :radix 16)
+			  (subseq line 11)))
+	    (multiple-value-bind
+		(old-value found)
+		(gethash name *cold-foreign-symbol-table*)
+	      (when found
+		(warn "Redefining ~S from #x~X to #x~X" name old-value value)))
+	    (setf (gethash name *cold-foreign-symbol-table*) value))))
+      version)))
+
+(defun lookup-foreign-symbol (name)
+  (multiple-value-bind
+      (value found)
+      (gethash name *cold-foreign-symbol-table* 0)
+    (unless found
+      (warn "Undefined foreign symbol: ~S" name))
+    value))
+
+
+(defvar *cold-assembler-routines* nil)
+
+(defvar *cold-assembler-fixups* nil)
+
+(defun record-cold-assembler-routine (name address)
+  (push (cons name address)
+	*cold-assembler-routines*))
+
+(defun record-cold-assembler-fixup
+       (routine code-object offset &optional (kind :both))
+  (push (list routine code-object offset kind)
+	*cold-assembler-fixups*))
+
+(defun lookup-assembler-reference (symbol)
+  (let ((value (cdr (assoc symbol *cold-assembler-routines*))))
+    (unless value (warn "Assembler routine ~S not defined." symbol))
+    value))
+
+(defun resolve-assembler-fixups ()
+  (dolist (fixup *cold-assembler-fixups*)
+    (let* ((routine (car fixup))
+	   (value (lookup-assembler-reference routine)))
+      (when value
+	(do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
+
+(defun do-cold-fixup (code-object offset value kind)
+  (let ((sap (sap+ (descriptor-sap code-object) offset)))
+    (ecase (c:backend-fasl-file-implementation c:*backend*)
+      (#.c:pmax-fasl-file-implementation
+       (ecase kind
+	 (:jump
+	  (assert (zerop (ash value -26)))
+	  (setf (ldb (byte 26 0) (sap-ref-32 sap 0))
+		(ash value -2)))
+	 (:lui
+	  (setf (sap-ref-16 sap 0)
+		(+ (ash value -16)
+		   (if (logbitp 15 value) 1 0))))
+	 (:addi
+	  (setf (sap-ref-16 sap 0)
+		(ldb (byte 16 0) value)))))
+      (#.c:sparc-fasl-file-implementation
+       (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
+	 (ecase kind
+	   (:call
+	    (error "Can't deal with call fixups yet."))
+	   (:sethi
+	    (setf inst
+		  (dpb (ldb (byte 22 10) value)
+		       (byte 22 0)
+		       inst)))
+	   (:add
+	    (setf inst
+		  (dpb (ldb (byte 10 0) value)
+		       (byte 10 0)
+		       inst))))
+	 (setf (sap-ref-32 sap 0)
+	       (maybe-byte-swap inst))))
+      ((#.c:rt-fasl-file-implementation 
+	#.c:rt-afpa-fasl-file-implementation)
+       (ecase kind
+	 (:cal
+	  (setf (sap-ref-16 sap 2)
+		(maybe-byte-swap-short
+		 (ldb (byte 16 0) value))))
+	 (:cau
+	  (let ((high (ldb (byte 16 16) value)))
+	    (setf (sap-ref-16 sap 2)
+		  (maybe-byte-swap-short
+		   (if (logbitp 15 value) (1+ high) high)))))
+	 (:ba
+	  (unless (zerop (ash value -24))
+	    (warn "#x~8,'0X out of range for branch-absolute." value))
+	  (let ((inst (maybe-byte-swap-short (sap-ref-16 sap 0))))
+	    (setf (sap-ref-16 sap 0)
+		  (maybe-byte-swap-short
+		   (dpb (ldb (byte 8 16) value)
+			(byte 8 0)
+			inst))))
+	  (setf (sap-ref-16 sap 2)
+		(maybe-byte-swap-short (ldb (byte 16 0) value))))))
+      (#.c:x86-fasl-file-implementation
+       (let* ((disp (logior (sap-ref-8 sap 0)
+			    (ash (sap-ref-8 sap 1) 8)
+			    (ash (sap-ref-8 sap 2) 16)
+			    (ash (sap-ref-8 sap 3) 24)))
+	      (high (descriptor-high code-object))
+	      (low (descriptor-low code-object))
+	      (value (ecase kind
+		       (:absolute (+ value disp))
+		       (:relative (- (+ value disp vm:other-pointer-type)
+				     (ash high descriptor-low-bits)
+				     low offset 4)))))
+	 (setf (sap-ref-8 sap 0) (ldb (byte 8 0) value))
+	 (setf (sap-ref-8 sap 1) (ldb (byte 8 8) value))
+	 (setf (sap-ref-8 sap 2) (ldb (byte 8 16) value))
+	 (setf (sap-ref-8 sap 3) (ldb (byte 8 24) value))))
+      (#.c:hppa-fasl-file-implementation
+       (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
+	 (setf (sap-ref-32 sap 0)
+	       (maybe-byte-swap
+		(ecase kind
+		  (:load
+		   (logior (ash (ldb (byte 11 0) value) 1)
+			   (logand inst #xffffc000)))
+		  (:load-short
+		   (let ((low-bits (ldb (byte 11 0) value)))
+		     (assert (<= 0 low-bits (1- (ash 1 4))))
+		     (logior (ash low-bits 17)
+			     (logand inst #xffe0ffff))))
+		  (:hi
+		   (logior (ash (ldb (byte 5 13) value) 16)
+			   (ash (ldb (byte 2 18) value) 14)
+			   (ash (ldb (byte 2 11) value) 12)
+			   (ash (ldb (byte 11 20) value) 1)
+			   (ldb (byte 1 31) value)
+			   (logand inst #xffe00000)))
+		  (:branch
+		   (let ((bits (ldb (byte 9 2) value)))
+		     (assert (zerop (ldb (byte 2 0) value)))
+		     (logior (ash bits 3)
+			     (logand inst #xffe0e002)))))))))))
+  (undefined-value))
+
+(defun linkage-info-to-core ()
+  (let ((result *nil-descriptor*))
+    (maphash #'(lambda (symbol value)
+		 (cold-push (allocate-cons *dynamic*
+					   (string-to-core symbol)
+					   (number-to-core value))
+			    result))
+	     *cold-foreign-symbol-table*)
+    (cold-setq (cold-intern '*initial-foreign-symbols*) result))
+  (let ((result *nil-descriptor*))
+    (dolist (rtn *cold-assembler-routines*)
+      (cold-push (allocate-cons *dynamic*
+				(cold-intern (car rtn))
+				(number-to-core (cdr rtn)))
+		 result))
+    (cold-setq (cold-intern '*initial-assembler-routines*) result)))
+
+
+
+;;;; Emit C Header.
+
+(defun tail-comp (string tail)
+  (and (>= (length string) (length tail))
+       (string= string tail :start1 (- (length string) (length tail)))))
+
+(defun head-comp (string head)
+  (and (>= (length string) (length head))
+       (string= string head :end1 (length head))))
+
+(defun emit-c-header-aux ()
+  (format t "/*~% * Machine generated header file.  Do not edit.~% */~2%")
+  (format t "#ifndef _INTERNALS_H_~%#define _INTERNALS_H_~2%")
+  (let ((constants nil))
+    (do-external-symbols (symbol (find-package "VM"))
+      (when (constantp symbol)
+	(let ((name (symbol-name symbol)))
+	  (labels
+	      ((record (prefix string priority)
+		 (push (list (concatenate
+			      'simple-string
+			      prefix
+			      (delete #\- (string-capitalize string)))
+			     priority
+			     (symbol-value symbol)
+			     (documentation symbol 'variable))
+		       constants))
+	       (test-tail (tail prefix priority)
+		 (when (tail-comp name tail)
+		   (record prefix
+			   (subseq name 0
+				   (- (length name)
+				      (length tail)))
+			   priority)))
+	       (test-head (head prefix priority)
+		 (when (head-comp name head)
+		   (record prefix
+			   (subseq name (length head))
+			   priority))))
+	    (test-tail "-TYPE" "type_" 0)
+	    (test-tail "-FLAG" "flag_" 1)
+	    (test-tail "-TRAP" "trap_" 2)
+	    (test-tail "-SUBTYPE" "subtype_" 3)
+	    (test-head "TRACE-TABLE-" "tracetab_" 4)
+	    (test-tail "-SC-NUMBER" "sc_" 5)))))
+    (setf constants
+	  (sort constants
+		#'(lambda (const1 const2)
+		    (if (= (second const1) (second const2))
+			(< (third const1) (third const2))
+			(< (second const1) (second const2))))))
+    (let ((prev-priority (second (car constants))))
+      (dolist (const constants)
+	(unless (= prev-priority (second const))
+	  (terpri)
+	  (setf prev-priority (second const)))
+	(format t "#define ~A ~D~@[  /* ~A */~]~%"
+		(first const) (third const) (fourth const))))
+    (terpri)
+    (format t "#define ERRORS { \\~%")
+    (loop
+      for info across (c:backend-internal-errors c:*backend*)
+      do (format t "    ~S, \\~%" (cdr info)))
+    (format t "    NULL \\~%}~%")
+    (terpri))
+  (let ((structs (sort (copy-list vm:*primitive-objects*) #'string<
+		       :key #'(lambda (obj)
+				(symbol-name
+				 (vm:primitive-object-name obj))))))
+    (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
+    (format t "#define LISPOBJ(x) ((lispobj)x)~2%")
+    (dolist (obj structs)
+      (format t "struct ~A {~%"
+	      (nsubstitute #\_ #\-
+			   (string-downcase
+			    (string (vm:primitive-object-name obj)))))
+      (when (vm:primitive-object-header obj)
+	(format t "    lispobj header;~%"))
+      (dolist (slot (vm:primitive-object-slots obj))
+	(format t "    ~A ~A~@[[1]~];~%"
+		(getf (vm:slot-options slot) :c-type "lispobj")
+		(nsubstitute #\_ #\-
+			     (string-downcase (string (vm:slot-name slot))))
+		(vm:slot-rest-p slot)))
+      (format t "};~2%"))
+    (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
+    (format t "#define LISPOBJ(thing) thing~2%")
+    (dolist (obj structs)
+      (let ((name (vm:primitive-object-name obj))
+	    (lowtag (eval (vm:primitive-object-lowtag obj))))
+	(when lowtag
+	  (dolist (slot (vm:primitive-object-slots obj))
+	    (format t "#define ~A_~A_OFFSET ~D~%"
+		    (substitute #\_ #\- (string name))
+		    (substitute #\_ #\- (string (vm:slot-name slot)))
+		    (- (* (vm:slot-offset slot) vm:word-bytes) lowtag)))
+	  (terpri))))
+    (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
+  (dolist (symbol (cons nil vm:static-symbols))
+    (format t "#define ~A LISPOBJ(0x~X)~%"
+	    (nsubstitute #\_ #\-
+			 (remove-if #'(lambda (char)
+					(member char '(#\% #\*)))
+				    (symbol-name symbol)))
+	    (if *static*
+		;; We actually ran Genesis, use the real value.
+		(descriptor-bits (cold-intern symbol))
+		;; We didn't run Genesis, so guess at the address.
+		(+ vm:target-static-space-start
+		   vm:word-bytes
+		   vm:other-pointer-type
+		   (if symbol (vm:static-symbol-offset symbol) 0)))))
+  (format t "~%#endif~%"))
+
+;;; FILES-DIFFER --- internal
+;;;
+;;; Return T iff the two files differ.
+;;;
+(defun files-differ (name1 name2)
+  (with-open-file (file1 name1)
+    (with-open-file (file2 name2)
+      (or (not (= (file-length file1)
+		  (file-length file2)))
+	  (do ((line1 "foo" (read-line file1 nil nil))
+	       (line2 "foo" (read-line file2 nil nil)))
+	      ((and (null line1) (null line2)) nil)
+	    (when (or (null line1)
+		      (null line2)
+		      (string/= line1 line2))
+	      (return t)))))))
+
+(defun emit-c-header (name)
+  (let* ((new-name (concatenate 'string (namestring name) ".NEW"))
+	 (unix-newname (unix-namestring new-name nil)))
+    (with-open-file
+	(*standard-output* new-name
+			   :direction :output
+			   :if-exists :supersede)
+      (emit-c-header-aux))
+    (cond ((not (probe-file name))
+	   (unix:unix-chmod unix-newname #o444)
+	   (rename-file new-name name))
+	  ((files-differ name new-name)
+	   (rename-file name
+			(concatenate 'simple-string
+				     (namestring name)
+				     ".OLD"))
+	   (unix:unix-chmod unix-newname #o444)
+	   (rename-file new-name name)
+	   (warn "The C header file has changed.~%Be sure to ~
+		  re-compile the startup code."))
+	  (t
+	   (unix:unix-unlink unix-newname))))
+  (undefined-value))
+
+
+;;;; The actual genesis function.
+
+(defvar *genesis-core-name* "lisp.core")
+(defvar *genesis-map-name* nil)
+(defvar *genesis-c-header-name* t)
+(defvar *genesis-symbol-table* nil)
+
+(defun genesis (file-list &optional
+			  (symbol-table *genesis-symbol-table*)
+			  (core-name *genesis-core-name*)
+			  (map-name *genesis-map-name*)
+			  (header-name *genesis-c-header-name*))
+  "Builds a kernel Lisp image from the .FASL files specified in the given
+  File-List and writes it to a file named by Core-Name."
+  (unless symbol-table
+    (error "Can't genesis without a symbol-table."))
+  (format t "~&Building ~S for the ~A~%"
+	  core-name (c:backend-version c:*backend*))
+  (setq *current-init-functions-cons* *nil-descriptor*)
+  (let ((*load-time-value-counter* 0)
+	*static* *dynamic* *read-only* *cold-assembler-routines*
+	*cold-assembler-fixups*)
+    (unwind-protect
+	(progn
+	  (clrhash *fdefn-objects*)
+	  (clrhash *cold-symbols*)
+	  (init-foreign-symbol-table)
+	  (let ((version (load-foreign-symbol-table symbol-table)))
+	    (initialize-spaces)
+	    (initialize-symbols)
+	    (setf *current-init-functions-cons* *nil-descriptor*)
+	    (initialize-static-fns)
+	    (dolist (file (if (listp file-list)
+			      file-list
+			      (list file-list)))
+	      (let ((file (truename
+			   (merge-pathnames file
+					    (make-pathname
+					     :type
+					     (c:backend-fasl-file-type
+					      c:*backend*))))))
+		(write-line (namestring file))
+		(cold-load file))
+	      (maybe-gc))
+	    (resolve-assembler-fixups)
+	    (linkage-info-to-core)
+	    (finish-symbols)
+	    (finalize-load-time-value-noise)
+	    (when map-name
+	      (with-open-file
+		  (*standard-output* (if (eq map-name t)
+					 (make-pathname
+					  :type "map"
+					  :defaults core-name)
+					 (merge-pathnames
+					  map-name
+					  (make-pathname :type "map"
+							 :defaults core-name)))
+				     :direction :output
+				     :if-exists :supersede)
+		(write-map-file)))
+	    (when header-name
+	      (emit-c-header
+	       (merge-pathnames (if (eq header-name t)
+				    "internals.h"
+				    (merge-pathnames
+				     header-name
+				     (make-pathname :type "h")))
+				core-name)))
+	    (write-initial-core-file core-name version)))
+      (dolist (space (list *static* *dynamic* *read-only*))
+	(when space
+	  (deallocate-space space))))))
+
+
+(defun write-map-file ()
+  (let ((*print-pretty* nil)
+	(*print-case* :upcase))
+    (format t "Assembler routines defined in core image:~2%")
+    (dolist (routine (sort (copy-list *cold-assembler-routines*) #'<
+			   :key #'cdr))
+      (format t "#x~8,'0X: ~S~%" (cdr routine) (car routine)))
+    (let ((funs nil) (undefs nil))
+      (maphash #'(lambda (name fdefn)
+		   (let ((fun (read-indexed fdefn vm:fdefn-function-slot)))
+		     (if (= (descriptor-bits fun)
+			    (descriptor-bits *nil-descriptor*))
+			 (push name undefs)
+			 (let ((addr (read-indexed fdefn
+						   vm:fdefn-raw-addr-slot)))
+			   (push (cons name (descriptor-bits addr))
+				 funs)))))
+	       *fdefn-objects*)
+      (format t "~2%Initially defined functions:~2%")
+      (dolist (info (sort funs #'< :key #'cdr))
+	(format t "#x~8,'0X: ~S~%" (cdr info) (car info)))
+      (format t "~2%Undefined function references:~2%")
+      (labels ((key (name)
+		 (etypecase name
+		   (symbol (symbol-name name))
+		   (integer (prin1-to-string name))
+		   (list (key (second name))))))
+	(dolist (fun (sort undefs #'string< :key #'key))
+	  (format t "~S~%" fun)))))
+  (undefined-value))
+
+
+;;;; Core file writing magic.
+
+(defvar *core-file* nil)
+(defvar *data-page* 0)
+
+(defparameter version-entry-type-code 3860)
+(defparameter validate-entry-type-code 3845)
+(defparameter directory-entry-type-code 3841)
+(defparameter new-directory-entry-type-code 3861)
+(defparameter end-entry-type-code 3840)
+
+(defun write-long (num)
+  (ecase (c:backend-byte-order c:*backend*)
+    (:little-endian
+     (dotimes (i 4)
+       (write-byte (ldb (byte 8 (* i 8)) num) *core-file*)))
+    (:big-endian
+     (dotimes (i 4)
+       (write-byte (ldb (byte 8 (* (- 3 i) 8)) num) *core-file*)))))
+
+
+(defun advance-to-page ()
+  (force-output *core-file*)
+  (file-position *core-file*
+		 (round-up (file-position *core-file*)
+			   (c:backend-page-size c:*backend*))))
+
+(defun output-space (space)
+  (force-output *core-file*)
+  (let* ((posn (file-position *core-file*))
+	 (bytes (* (space-free-pointer space) vm:word-bytes))
+	 (pages (ceiling bytes (c:backend-page-size c:*backend*)))
+	 (total-bytes (* pages (c:backend-page-size c:*backend*))))
+    ;; 
+    (file-position *core-file* (* (c:backend-page-size c:*backend*)
+				  (1+ *data-page*)))
+    (format t "Writing ~S byte~:P [~S page~:P] from ~S space~%"
+	    total-bytes pages (space-name space))
+    (force-output)
+    ;;
+    ;; Note: It is assumed that the space allocation routines always
+    ;; allocate whole pages (of size *target-page-size*) and that any empty
+    ;; space between the free pointer and the end of page will be
+    ;; zero-filled.  This will always be true under Mach on machines
+    ;; where the page size is equal.  (RT is 4K, PMAX is 4K, Sun 3 is 8K).
+    ;; 
+    (system:output-raw-bytes *core-file* (space-sap space) 0 total-bytes)
+    (force-output *core-file*)
+    (file-position *core-file* posn)
+    ;; 
+    ;; Write part of a (new) directory entry which looks like this:
+    ;;
+    ;; SPACE IDENTIFIER
+    ;; WORD COUNT
+    ;; DATA PAGE
+    ;; ADDRESS
+    ;; PAGE COUNT
+    ;; 
+    (write-long (space-identifier space))
+    (write-long (space-free-pointer space))
+    (write-long *data-page*)
+    (write-long (/ (ash (space-address space) vm:word-shift)
+		   (c:backend-page-size c:*backend*)))
+    (write-long pages)
+    (incf *data-page* pages)))
+
+(defun write-initial-core-file (name version)
+  (format t "[Building Initial Core File (version ~D) in file ~S: ~%"
+	  version (namestring name))
+  (force-output)
+  (let ((*data-page* 0))
+    (with-open-file (*core-file* name
+				 :direction :output
+				 :element-type '(unsigned-byte 8)
+				 :if-exists :rename-and-delete)
+      ;; Write the magic number
+      ;; 
+      (write-long (logior (ash (char-code #\C) 24)
+			  (ash (char-code #\O) 16)
+			  (ash (char-code #\R) 8)
+			  (char-code #\E)))
+      
+      ;; Write the Version entry.
+      ;; 
+      (write-long version-entry-type-code)
+      (write-long 3)
+      (write-long version)
+
+      ;; Write the New Directory entry header.
+      ;; 
+      (write-long new-directory-entry-type-code)
+      (write-long 17) ; length = 5 words / space * 3 spaces + 2 for header.
+      
+      (output-space *read-only*)
+      (output-space *static*)
+      (output-space *dynamic*)
+      
+      ;; Write the End entry.
+      ;; 
+      (write-long end-entry-type-code)
+      (write-long 2)))
+  (format t "done]~%")
+  (force-output))
+
diff --git a/compiler/hppa/alloc.lisp b/compiler/hppa/alloc.lisp
new file mode 100644
index 000000000..95b58f1b3
--- /dev/null
+++ b/compiler/hppa/alloc.lisp
@@ -0,0 +1,197 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/alloc.lisp,v 1.1 1992/07/13 03:48:14 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Allocation VOPs for the HPPA port.
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "HPPA")
+
+
+;;;; LIST and LIST*
+
+(define-vop (list-or-list*)
+  (:args (things :more t))
+  (:temporary (:scs (descriptor-reg) :type list) ptr)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
+	      res)
+  (:info num)
+  (:results (result :scs (descriptor-reg)))
+  (:variant-vars star)
+  (:policy :safe)
+  (:generator 0
+    (cond
+     ((zerop num)
+      (move null-tn result))
+     ((and star (= num 1))
+      (move (tn-ref-tn things) result))
+     (t
+      (macrolet
+	  ((maybe-load (tn)
+	     (once-only ((tn tn))
+	       `(sc-case ,tn
+		  ((any-reg descriptor-reg zero null)
+		   ,tn)
+		  (control-stack
+		   (load-stack-tn temp ,tn)
+		   temp)))))
+	(let* ((cons-cells (if star (1- num) num))
+	       (alloc (* (pad-data-block cons-size) cons-cells)))
+	  (pseudo-atomic (:extra alloc)
+	    (move alloc-tn res)
+	    (inst dep list-pointer-type 31 3 res)
+	    (move res ptr)
+	    (dotimes (i (1- cons-cells))
+	      (storew (maybe-load (tn-ref-tn things)) ptr
+		      cons-car-slot list-pointer-type)
+	      (setf things (tn-ref-across things))
+	      (inst addi (pad-data-block cons-size) ptr ptr)
+	      (storew ptr ptr
+		      (- cons-cdr-slot cons-size)
+		      list-pointer-type))
+	    (storew (maybe-load (tn-ref-tn things)) ptr
+		    cons-car-slot list-pointer-type)
+	    (storew (if star
+			(maybe-load (tn-ref-tn (tn-ref-across things)))
+			null-tn)
+		    ptr cons-cdr-slot list-pointer-type))
+	  (move res result)))))))
+
+
+(define-vop (list list-or-list*)
+  (:variant nil))
+
+(define-vop (list* list-or-list*)
+  (:variant t))
+
+
+;;;; Special purpose inline allocators.
+
+(define-vop (allocate-code-object)
+  (:args (boxed-arg :scs (any-reg))
+	 (unboxed-arg :scs (any-reg)))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
+  (:generator 100
+    (inst addi (fixnum (1+ code-trace-table-offset-slot)) boxed-arg boxed)
+    (inst dep 0 31 3 boxed)
+    (inst srl unboxed-arg word-shift unboxed)
+    (inst addi lowtag-mask unboxed unboxed)
+    (inst dep 0 31 3 unboxed)
+    (pseudo-atomic ()
+      ;; Note: we don't have to subtract off the 4 that was added by
+      ;; pseudo-atomic, because depositing other-pointer-type just adds
+      ;; it right back.
+      (inst move alloc-tn result)
+      (inst dep other-pointer-type 31 3 result)
+      (inst add alloc-tn boxed alloc-tn)
+      (inst add alloc-tn unboxed alloc-tn)
+      (inst sll boxed (- type-bits word-shift) ndescr)
+      (inst addi code-header-type ndescr ndescr)
+      (storew ndescr result 0 other-pointer-type)
+      (storew unboxed result code-code-size-slot other-pointer-type)
+      (storew null-tn result code-entry-points-slot other-pointer-type)
+      (storew null-tn result code-debug-info-slot other-pointer-type))))
+
+(define-vop (make-fdefn)
+  (:args (name :scs (descriptor-reg) :to :eval))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (descriptor-reg) :from :argument))
+  (:policy :fast-safe)
+  (:translate make-fdefn)
+  (:generator 37
+    (with-fixed-allocation (result temp fdefn-type fdefn-size)
+      (inst li (make-fixup "undefined_tramp" :foreign) temp)
+      (storew name result fdefn-name-slot other-pointer-type)
+      (storew null-tn result fdefn-function-slot other-pointer-type)
+      (storew temp result fdefn-raw-addr-slot other-pointer-type))))
+
+
+;;;; Automatic allocators for primitive objects.
+
+(define-for-each-primitive-object (obj)
+  (collect ((forms))
+    (let* ((options (primitive-object-options obj))
+	   (alloc-trans (getf options :alloc-trans))
+	   (alloc-vop (getf options :alloc-vop alloc-trans))
+	   (header (primitive-object-header obj))
+	   (lowtag (primitive-object-lowtag obj))
+	   (size (primitive-object-size obj))
+	   (variable-length (primitive-object-variable-length obj))
+	   (need-unbound-marker nil))
+      (collect ((args) (init-forms))
+	(when (and alloc-vop variable-length)
+	  (args 'extra-words))
+	(dolist (slot (primitive-object-slots obj))
+	  (let* ((name (slot-name slot))
+		 (offset (slot-offset slot)))
+	    (ecase (getf (slot-options slot) :init :zero)
+	      (:zero)
+	      (:null
+	       (init-forms `(storew null-tn result ,offset ,lowtag)))
+	      (:unbound
+	       (setf need-unbound-marker t)
+	       (init-forms `(storew temp result ,offset ,lowtag)))
+	      (:arg
+	       (args name)
+	       (init-forms `(storew ,name result ,offset ,lowtag))))))
+	(when (and (null alloc-vop) (args))
+	  (error "Slots ~S want to be initialized, but there is no alloc vop ~
+	          defined for ~S."
+		 (args) (primitive-object-name obj)))
+	(when alloc-vop
+	  (forms
+	   `(define-vop (,alloc-vop)
+	      (:args ,@(mapcar #'(lambda (name)
+				   `(,name :scs (any-reg descriptor-reg)))
+			       (args)))
+	      ,@(when (or need-unbound-marker header variable-length)
+		  `((:temporary (:scs (non-descriptor-reg)) temp)))
+	      (:results (result :scs (descriptor-reg) :from :load))
+	      (:policy :fast-safe)
+	      ,@(when alloc-trans
+		  `((:translate ,alloc-trans)))
+	      (:generator 37
+		(pseudo-atomic (,@(unless variable-length
+				    `(:extra (pad-data-block ,size))))
+		  (move alloc-tn result)
+		  (inst dep ,lowtag 31 3 result)
+		  ,@(cond
+		     ((and header variable-length)
+		      `((inst addi (* (1+ ,size) word-bytes) extra-words temp)
+			(inst dep 0 31 3 temp)
+			(inst add temp alloc-tn alloc-tn)
+			(inst sll extra-words (- type-bits word-shift) temp)
+			(inst addi (+ (ash (1- ,size) type-bits) ,header)
+			      temp temp)
+			(storew temp result 0 ,lowtag)))
+		     (variable-length
+		      (error ":REST-P T with no header in ~S?"
+			     (primitive-object-name obj)))
+		     (header
+		      `((inst li ,(logior (ash (1- size) type-bits)
+					  (symbol-value header))
+			      temp)
+			(storew temp result 0 ,lowtag)))
+		     (t
+		      nil))
+		  ,@(when need-unbound-marker
+		      `((inst li unbound-marker-type temp)))
+		  ,@(init-forms))))))))
+    (when (forms)
+      `(progn
+	 ,@(forms)))))
diff --git a/compiler/hppa/arith.lisp b/compiler/hppa/arith.lisp
new file mode 100644
index 000000000..f2d1c9433
--- /dev/null
+++ b/compiler/hppa/arith.lisp
@@ -0,0 +1,851 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/arith.lisp,v 1.1 1992/07/13 03:48:15 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition arithmetic VOPs for the HP-PA.
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "HPPA")
+
+
+
+;;;; Unary operations.
+
+(define-vop (fixnum-unop)
+  (:args (x :scs (any-reg)))
+  (:results (res :scs (any-reg)))
+  (:note "inline fixnum arithmetic")
+  (:arg-types tagged-num)
+  (:result-types tagged-num)
+  (:policy :fast-safe))
+
+(define-vop (signed-unop)
+  (:args (x :scs (signed-reg)))
+  (:results (res :scs (signed-reg)))
+  (:note "inline (signed-byte 32) arithmetic")
+  (:arg-types signed-num)
+  (:result-types signed-num)
+  (:policy :fast-safe))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+  (:translate %negate)
+  (:generator 1
+    (inst sub zero-tn x res)))
+
+(define-vop (fast-negate/signed signed-unop)
+  (:translate %negate)
+  (:generator 2
+    (inst sub zero-tn x res)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+  (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
+	      temp)
+  (:translate lognot)
+  (:generator 2
+    (inst li (fixnum -1) temp)
+    (inst xor x temp res)))
+
+(define-vop (fast-lognot/signed signed-unop)
+  (:translate lognot)
+  (:generator 1
+    (inst uaddcm zero-tn x res)))
+
+
+
+;;;; Binary fixnum operations.
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop)
+  (:args (x :target r :scs (any-reg))
+	 (y :target r :scs (any-reg)))
+  (:arg-types tagged-num tagged-num)
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(define-vop (fast-unsigned-binop)
+  (:args (x :target r :scs (unsigned-reg))
+	 (y :target r :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic")
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(define-vop (fast-signed-binop)
+  (:args (x :target r :scs (signed-reg))
+	 (y :target r :scs (signed-reg)))
+  (:arg-types signed-num signed-num)
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(defmacro define-binop (translate cost untagged-cost op)
+  `(progn
+     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+		  fast-fixnum-binop)
+       (:args (x :target r :scs (any-reg))
+	      (y :target r :scs (any-reg)))
+       (:translate ,translate)
+       (:generator ,cost
+	 (inst ,op x y r)))
+     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+		  fast-signed-binop)
+       (:args (x :target r :scs (signed-reg))
+	      (y :target r :scs (signed-reg)))
+       (:translate ,translate)
+       (:generator ,untagged-cost
+	 (inst ,op x y r)))
+     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+		  fast-unsigned-binop)
+       (:args (x :target r :scs (unsigned-reg))
+	      (y :target r :scs (unsigned-reg)))
+       (:translate ,translate)
+       (:generator ,untagged-cost
+	 (inst ,op x y r)))))
+
+(define-binop + 2 6 add)
+(define-binop - 2 6 sub)
+(define-binop logior 1 2 or)
+(define-binop logand 1 2 and)
+(define-binop logandc2 1 2 andcm)
+(define-binop logxor 1 2 xor)
+
+(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
+  (:args (x :target r :scs (any-reg)))
+  (:info y)
+  (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-signed-c-binop fast-signed-binop)
+  (:args (x :target r :scs (signed-reg)))
+  (:info y)
+  (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
+  (:args (x :target r :scs (unsigned-reg)))
+  (:info y)
+  (:arg-types tagged-num (:constant integer)))
+
+(defmacro define-c-binop (translate cost untagged-cost tagged-type
+				    untagged-type inst)
+  `(progn
+     (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
+		  fast-fixnum-c-binop)
+       (:arg-types tagged-num (:constant ,tagged-type))
+       (:translate ,translate)
+       (:generator ,cost
+	 (let ((y (fixnum y)))
+	   ,inst)))
+     (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
+		  fast-signed-c-binop)
+       (:arg-types signed-num (:constant ,untagged-type))
+       (:translate ,translate)
+       (:generator ,untagged-cost
+	 ,inst))
+     (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
+		  fast-unsigned-c-binop)
+       (:arg-types unsigned-num (:constant ,untagged-type))
+       (:translate ,translate)
+       (:generator ,untagged-cost
+	 ,inst))))
+
+(define-c-binop + 1 3 (signed-byte 9) (signed-byte 11)
+  (inst addi y x r))
+(define-c-binop - 1 3
+  (integer #.(- (1- (ash 1 9))) #.(ash 1 9))
+  (integer #.(- (1- (ash 1 11))) #.(ash 1 11))
+  (inst addi (- y) x r))
+
+;;; Special case fixnum + and - that trap on overflow.  Useful when we don't
+;;; know that the result is going to be a fixnum.
+
+(define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:note nil)
+  (:generator 4
+    (inst addo x y r)))
+
+(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:note nil)
+  (:generator 3
+    (inst addio (fixnum y) x r)))
+
+(define-vop (fast--/fixnum fast--/fixnum=>fixnum)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:note nil)
+  (:generator 4
+    (inst subo x y r)))
+
+(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:note nil)
+  (:generator 3
+    (inst addio (- (fixnum y)) x r)))
+
+;;; Shifting
+
+(define-vop (fast-ash)
+  (:policy :fast-safe)
+  (:translate ash)
+  (:note "inline word ASH")
+  (:args (number :scs (signed-reg unsigned-reg))
+	 (count :scs (signed-reg)))
+  (:arg-types (:or signed-num unsigned-num) tagged-num)
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+  (:results (result :scs (signed-reg unsigned-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:generator 8
+    (inst comb :>= count zero-tn positive :nullify t)
+    (inst sub zero-tn count temp)
+    (inst comiclr 31 temp zero-tn :>=)
+    (inst li 31 temp)
+    (inst mtctl temp :sar)
+    (inst extrs number 0 1 temp)
+    (inst b done)
+    (inst shd temp number :variable result)
+    POSITIVE
+    (inst subi 31 count temp)
+    (inst mtctl temp :sar)
+    (inst zdep number :variable 32 result)
+    DONE))
+
+(define-vop (fast-ash-c)
+  (:policy :fast-safe)
+  (:translate ash)
+  (:note nil)
+  (:args (number :scs (signed-reg unsigned-reg)))
+  (:info count)
+  (:arg-types (:or signed-num unsigned-num) (:constant integer))
+  (:results (result :scs (signed-reg unsigned-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:generator 1
+    (cond ((< count 0)
+	   ;; It is a right shift.
+	   (inst sra number (min (- count) 31) result))
+	  ((> count 0)
+	   ;; It is a left shift.
+	   (inst sll number (min count 31) result))
+	  (t
+	   ;; Count=0?  Shouldn't happen, but it's easy:
+	   (move number result)))))
+
+
+(define-vop (signed-byte-32-len)
+  (:translate integer-length)
+  (:note "inline (signed-byte 32) integer-length")
+  (:policy :fast-safe)
+  (:args (arg :scs (signed-reg) :target shift))
+  (:arg-types signed-num)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
+  (:generator 30
+    (inst move arg shift :>=)
+    (inst uaddcm zero-tn shift shift)
+    (inst comb := shift zero-tn done)
+    (inst li 0 res)
+    LOOP
+    (inst srl shift 1 shift)
+    (inst comb :<> shift zero-tn loop)
+    (inst addi (fixnum 1) res res)
+    DONE))
+
+(define-vop (unsigned-byte-32-count)
+  (:translate logcount)
+  (:note "inline (unsigned-byte 32) logcount")
+  (:policy :fast-safe)
+  (:args (arg :scs (unsigned-reg) :target num))
+  (:arg-types unsigned-num)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
+		    :target res) num)
+  (:temporary (:scs (non-descriptor-reg)) mask temp)
+  (:generator 30
+    (inst li #x55555555 mask)
+    (inst srl arg 1 temp)
+    (inst and arg mask num)
+    (inst and temp mask temp)
+    (inst add num temp num)
+    (inst li #x33333333 mask)
+    (inst srl num 2 temp)
+    (inst and num mask num)
+    (inst and temp mask temp)
+    (inst add num temp num)
+    (inst li #x0f0f0f0f mask)
+    (inst srl num 4 temp)
+    (inst and num mask num)
+    (inst and temp mask temp)
+    (inst add num temp num)
+    (inst li #x00ff00ff mask)
+    (inst srl num 8 temp)
+    (inst and num mask num)
+    (inst and temp mask temp)
+    (inst add num temp num)
+    (inst li #x0000ffff mask)
+    (inst srl num 16 temp)
+    (inst and num mask num)
+    (inst and temp mask temp)
+    (inst add num temp res)))
+
+;;; Multiply and Divide.
+
+(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
+  (:args (x :scs (any-reg) :target x-pass)
+	 (y :scs (any-reg) :target y-pass))
+  (:temporary (:sc signed-reg :offset nl0-offset
+		   :from (:argument 0) :to (:result 0)) x-pass)
+  (:temporary (:sc signed-reg :offset nl1-offset
+		   :from (:argument 1) :to (:result 0)) y-pass)
+  (:temporary (:sc signed-reg :offset nl2-offset :target r
+		   :from (:argument 1) :to (:result 0)) res-pass)
+  (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
+  (:temporary (:sc signed-reg :offset nl4-offset
+		   :from (:argument 1) :to (:result 0)) sign)
+  (:temporary (:sc interior-reg :offset lip-offset) lip)
+  (:ignore lip sign)
+  (:translate *)
+  (:generator 30
+    (unless (location= y y-pass)
+      (inst sra x 2 x-pass))
+    (let ((fixup (make-fixup 'multiply :assembly-routine)))
+      (inst ldil fixup tmp)
+      (inst ble fixup lisp-heap-space tmp))
+    (if (location= y y-pass)
+	(inst sra x 2 x-pass)
+	(inst move y y-pass))
+    (move res-pass r)))
+
+(define-vop (fast-*/signed=>signed fast-signed-binop)
+  (:translate *)
+  (:args (x :scs (signed-reg) :target x-pass)
+	 (y :scs (signed-reg) :target y-pass))
+  (:temporary (:sc signed-reg :offset nl0-offset
+		   :from (:argument 0) :to (:result 0)) x-pass)
+  (:temporary (:sc signed-reg :offset nl1-offset
+		   :from (:argument 1) :to (:result 0)) y-pass)
+  (:temporary (:sc signed-reg :offset nl2-offset :target r
+		   :from (:argument 1) :to (:result 0)) res-pass)
+  (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
+  (:temporary (:sc signed-reg :offset nl4-offset
+		   :from (:argument 1) :to (:result 0)) sign)
+  (:temporary (:sc interior-reg :offset lip-offset) lip)
+  (:ignore lip sign)
+  (:translate *)
+  (:generator 31
+    (let ((fixup (make-fixup 'multiply :assembly-routine)))
+      (move x x-pass)
+      (move y y-pass)
+      (inst ldil fixup tmp)
+      (inst ble fixup lisp-heap-space tmp :nullify t)
+      (inst nop)
+      (move res-pass r))))
+
+(define-vop (fast-truncate/fixnum fast-fixnum-binop)
+  (:translate truncate)
+  (:args (x :scs (any-reg) :target x-pass)
+	 (y :scs (any-reg) :target y-pass))
+  (:temporary (:sc signed-reg :offset nl0-offset
+		   :from (:argument 0) :to (:result 0)) x-pass)
+  (:temporary (:sc signed-reg :offset nl1-offset
+		   :from (:argument 1) :to (:result 0)) y-pass)
+  (:temporary (:sc signed-reg :offset nl2-offset :target q
+		   :from (:argument 1) :to (:result 0)) q-pass)
+  (:temporary (:sc signed-reg :offset nl3-offset :target r
+		   :from (:argument 1) :to (:result 1)) r-pass)
+  (:results (q :scs (signed-reg))
+	    (r :scs (any-reg)))
+  (:result-types tagged-num tagged-num)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 30
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (inst bc := nil y zero-tn zero))
+    (move x x-pass)
+    (move y y-pass)
+    (let ((fixup (make-fixup 'truncate :assembly-routine)))
+      (inst ldil fixup q-pass)
+      (inst ble fixup lisp-heap-space q-pass :nullify t))
+    (inst nop)
+    (move q-pass q)
+    (move r-pass r)))
+
+(define-vop (fast-truncate/signed fast-signed-binop)
+  (:translate truncate)
+  (:args (x :scs (signed-reg) :target x-pass)
+	 (y :scs (signed-reg) :target y-pass))
+  (:temporary (:sc signed-reg :offset nl0-offset
+		   :from (:argument 0) :to (:result 0)) x-pass)
+  (:temporary (:sc signed-reg :offset nl1-offset
+		   :from (:argument 1) :to (:result 0)) y-pass)
+  (:temporary (:sc signed-reg :offset nl2-offset :target q
+		   :from (:argument 1) :to (:result 0)) q-pass)
+  (:temporary (:sc signed-reg :offset nl3-offset :target r
+		   :from (:argument 1) :to (:result 1)) r-pass)
+  (:results (q :scs (signed-reg))
+	    (r :scs (signed-reg)))
+  (:result-types signed-num signed-num)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 35
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (inst bc := nil y zero-tn zero))
+    (move x x-pass)
+    (move y y-pass)
+    (let ((fixup (make-fixup 'truncate :assembly-routine)))
+      (inst ldil fixup q-pass)
+      (inst ble fixup lisp-heap-space q-pass :nullify t))
+    (inst nop)
+    (move q-pass q)
+    (move r-pass r)))
+
+
+;;;; Binary conditional VOPs:
+
+(define-vop (fast-conditional)
+  (:conditional)
+  (:info target not-p)
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(define-vop (fast-conditional/fixnum fast-conditional)
+  (:args (x :scs (any-reg))
+	 (y :scs (any-reg)))
+  (:arg-types tagged-num tagged-num)
+  (:note "inline fixnum comparison"))
+
+(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg)))
+  (:arg-types tagged-num (:constant (signed-byte 9)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/signed fast-conditional)
+  (:args (x :scs (signed-reg))
+	 (y :scs (signed-reg)))
+  (:arg-types signed-num signed-num)
+  (:note "inline (signed-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/signed fast-conditional/signed)
+  (:args (x :scs (signed-reg)))
+  (:arg-types signed-num (:constant (signed-byte 11)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/unsigned fast-conditional)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (:note "inline (unsigned-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
+  (:args (x :scs (unsigned-reg)))
+  (:arg-types unsigned-num (:constant (signed-byte 11)))
+  (:info target not-p y))
+
+
+(defmacro define-conditional-vop (translate signed-cond unsigned-cond)
+  `(progn
+     ,@(mapcar #'(lambda (suffix cost signed imm)
+		   (unless (and (member suffix '(/fixnum -c/fixnum))
+				(eq translate 'eql))
+		     `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+						    translate suffix))
+				   ,(intern
+				     (format nil "~:@(FAST-CONDITIONAL~A~)"
+					     suffix)))
+			(:translate ,translate)
+			(:generator ,cost
+			  (inst ,(if imm 'bci 'bc)
+				,(if signed signed-cond unsigned-cond)
+				not-p
+				,(if (eq suffix '-c/fixnum)
+				     '(fixnum y)
+				     'y)
+				x
+				target)))))
+	       '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+	       '(3 2 5 4 5 4)
+	       '(t t t t nil nil)
+	       '(nil t nil t nil t))))
+
+;; We switch < and > because the immediate has to come first.
+
+(define-conditional-vop < :> :>>)
+(define-conditional-vop > :< :<<)
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+;;;
+(define-conditional-vop eql := :=)
+
+;;; These versions specify a fixnum restriction on their first arg.  We have
+;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
+;;; the first arg and a higher cost.  The reason for doing this is to prevent
+;;; fixnum specific operations from being used on word integers, spuriously
+;;; consing the argument.
+;;;
+(define-vop (fast-eql/fixnum fast-conditional)
+  (:args (x :scs (any-reg descriptor-reg))
+	 (y :scs (any-reg)))
+  (:arg-types tagged-num tagged-num)
+  (:note "inline fixnum comparison")
+  (:translate eql)
+  (:generator 3
+    (inst bc := not-p x y target)))
+;;;
+(define-vop (generic-eql/fixnum fast-eql/fixnum)
+  (:arg-types * tagged-num)
+  (:variant-cost 7))
+
+(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:arg-types tagged-num (:constant (signed-byte 9)))
+  (:info target not-p y)
+  (:translate eql)
+  (:generator 2
+    (inst bci := not-p (fixnum y) x target)))
+;;;
+(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+  (:arg-types * (:constant (signed-byte 14)))
+  (:variant-cost 6))
+  
+
+;;;; 32-bit logical operations
+
+(define-vop (32bit-logical)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:policy :fast-safe))
+
+(define-vop (32bit-logical-not 32bit-logical)
+  (:translate 32bit-logical-not)
+  (:args (x :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:generator 1
+    (inst uaddcm zero-tn x r)))
+
+(define-vop (32bit-logical-and 32bit-logical)
+  (:translate 32bit-logical-and)
+  (:generator 1
+    (inst and x y r)))
+
+(deftransform 32bit-logical-nand ((x y) (* *))
+  '(32bit-logical-not (32bit-logical-and x y)))
+
+(define-vop (32bit-logical-or 32bit-logical)
+  (:translate 32bit-logical-or)
+  (:generator 1
+    (inst or x y r)))
+
+(deftransform 32bit-logical-nor ((x y) (* *))
+  '(32bit-logical-not (32bit-logical-or x y)))
+
+(define-vop (32bit-logical-xor 32bit-logical)
+  (:translate 32bit-logical-xor)
+  (:generator 1
+    (inst xor x y r)))
+
+(deftransform 32bit-logical-eqv ((x y) (* *))
+  '(32bit-logical-not (32bit-logical-xor x y)))
+
+(deftransform 32bit-logical-andc1 ((x y) (* *))
+  '(32bit-logical-and (32bit-logical-not x) y))
+
+(define-vop (32bit-logical-andc2 32bit-logical)
+  (:translate 32bit-logical-andc2)
+  (:generator 1
+    (inst andcm x y r)))
+
+(deftransform 32bit-logical-orc1 ((x y) (* *))
+  '(32bit-logical-or (32bit-logical-not x) y))
+
+(deftransform 32bit-logical-orc2 ((x y) (* *))
+  '(32bit-logical-or x (32bit-logical-not y)))
+
+
+(define-vop (shift-towards-someplace)
+  (:policy :fast-safe)
+  (:args (num :scs (unsigned-reg))
+	 (amount :scs (signed-reg)))
+  (:arg-types unsigned-num tagged-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num))
+
+(define-vop (shift-towards-start shift-towards-someplace)
+  (:translate shift-towards-start)
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+  (:note "SHIFT-TOWARDS-START")
+  (:generator 1
+    (inst subi 31 amount temp)
+    (inst mtctl temp :sar)
+    (inst zdep num :variable 32 r)))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+  (:translate shift-towards-end)
+  (:note "SHIFT-TOWARDS-END")
+  (:generator 1
+    (inst mtctl amount :sar)
+    (inst shd zero-tn num :variable r)))
+
+
+
+;;;; Bignum stuff.
+
+(define-vop (bignum-length get-header-data)
+  (:translate bignum::%bignum-length)
+  (:policy :fast-safe))
+
+(define-vop (bignum-set-length set-header-data)
+  (:translate bignum::%bignum-set-length)
+  (:policy :fast-safe))
+
+(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
+  (unsigned-reg) unsigned-num bignum::%bignum-ref)
+
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
+  (unsigned-reg) unsigned-num bignum::%bignum-set)
+
+(define-vop (digit-0-or-plus)
+  (:translate bignum::%digit-0-or-plusp)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:conditional)
+  (:info target not-p)
+  (:effects)
+  (:affected)
+  (:generator 1
+    (inst bc :>= not-p digit zero-tn target)))
+
+(define-vop (add-w/carry)
+  (:translate bignum::%add-with-carry)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg))
+	 (b :scs (unsigned-reg))
+	 (c :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg))
+	    (carry :scs (unsigned-reg)))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 3
+    (inst addi -1 c zero-tn)
+    (inst addc a b result)
+    (inst addc zero-tn zero-tn carry)))
+
+(define-vop (sub-w/borrow)
+  (:translate bignum::%subtract-with-borrow)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg))
+	 (b :scs (unsigned-reg))
+	 (c :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg))
+	    (borrow :scs (unsigned-reg)))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 4
+    (inst addi -1 c zero-tn)
+    (inst subb a b result)
+    (inst addc zero-tn zero-tn borrow)))
+
+(define-vop (bignum-mult)
+  (:translate bignum::%multiply)
+  (:policy :fast-safe)
+  (:args (x-arg :scs (unsigned-reg) :target x)
+	 (y-arg :scs (unsigned-reg) :target y))
+  (:arg-types unsigned-num unsigned-num)
+  (:temporary (:scs (signed-reg) :from (:argument 0)) x)
+  (:temporary (:scs (signed-reg) :from (:argument 1)) y)
+  (:temporary (:scs (signed-reg)) tmp)
+  (:results (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 3
+    ;; Make sure X is less then Y.
+    (inst comclr x-arg y-arg tmp :<<)
+    (inst xor x-arg y-arg tmp)
+    (inst xor x-arg tmp x)
+    (inst xor y-arg tmp y)
+
+    ;; Blow out of here if the result is zero.
+    (inst li 0 hi)
+    (inst comb := x zero-tn done)
+    (inst li 0 lo)
+    (inst li 0 tmp)
+
+    LOOP
+    (inst comb :ev x zero-tn next-bit)
+    (inst srl x 1 x)
+    (inst add lo y lo)
+    (inst addc hi tmp hi)
+    NEXT-BIT
+    (inst add y y y)
+    (inst comb :<> x zero-tn loop)
+    (inst addc tmp tmp tmp)
+
+    DONE))
+
+(def-source-transform bignum:%multiply-and-add (x y carry &optional (extra 0))
+  #+nil ;; This would be greate if it worked, but it doesn't.
+  (if (eql extra 0)
+      `(multiple-value-call #'bignum::%dual-word-add
+	 (bignum:%multiply ,x ,y)
+	 (values ,carry))
+      `(multiple-value-call #'bignum::%dual-word-add
+	 (multiple-value-call #'bignum::%dual-word-add
+	   (bignum:%multiply ,x ,y)
+	   (values ,carry))
+	 (values ,extra)))
+  (let ((hi (gensym "HI-"))
+	(lo (gensym "LO-")))
+    (if (eql extra 0)
+	`(multiple-value-bind (,hi ,lo) (bignum:%multiply ,x ,y)
+	   (bignum::%dual-word-add ,hi ,lo ,carry))
+	`(multiple-value-bind (,hi ,lo) (bignum:%multiply ,x ,y)
+	   (multiple-value-bind
+	       (,hi ,lo)
+	       (bignum::%dual-word-add ,hi ,lo ,carry)
+	     (bignum::%dual-word-add ,hi ,lo ,extra))))))
+
+(defknown bignum::%dual-word-add
+	  (bignum-element-type bignum-element-type bignum-element-type)
+  (values bignum-element-type bignum-element-type)
+  (flushable movable))
+
+(define-vop (dual-word-add)
+  (:policy :fast-safe)
+  (:translate bignum::%dual-word-add)
+  (:args (hi :scs (unsigned-reg) :to (:result 1))
+	 (lo :scs (unsigned-reg))
+	 (extra :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:results (hi-res :scs (unsigned-reg) :from (:result 1))
+	    (lo-res :scs (unsigned-reg) :from (:result 0)))
+  (:result-types unsigned-num unsigned-num)
+  (:affected)
+  (:effects)
+  (:generator 3
+    (inst add lo extra lo-res)
+    (inst addc hi zero-tn hi-res)))
+
+(define-vop (bignum-lognot)
+  (:translate bignum::%lognot)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (inst uaddcm zero-tn x r)))
+
+(define-vop (fixnum-to-digit)
+  (:translate bignum::%fixnum-to-digit)
+  (:policy :fast-safe)
+  (:args (fixnum :scs (signed-reg)))
+  (:arg-types tagged-num)
+  (:results (digit :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move fixnum digit)))
+
+(define-vop (bignum-floor)
+  (:translate bignum::%floor)
+  (:policy :fast-safe)
+  (:args (hi :scs (unsigned-reg) :to (:argument 1))
+	 (lo :scs (unsigned-reg) :to (:argument 0))
+	 (divisor :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
+  (:results (quo :scs (unsigned-reg) :from (:argument 0))
+	    (rem :scs (unsigned-reg) :from (:argument 1)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 65
+    (inst sub zero-tn divisor temp)
+    (inst ds zero-tn temp zero-tn)
+    (inst add lo lo quo)
+    (inst ds hi divisor rem)
+    (inst addc quo quo quo)
+    (dotimes (i 31)
+      (inst ds rem divisor rem)
+      (inst addc quo quo quo))
+    (inst comclr rem zero-tn zero-tn :>=)
+    (inst add divisor rem rem)))
+
+(define-vop (signify-digit)
+  (:translate bignum::%fixnum-digit-with-correct-sign)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg) :target res))
+  (:arg-types unsigned-num)
+  (:results (res :scs (signed-reg)))
+  (:result-types signed-num)
+  (:generator 1
+    (move digit res)))
+
+(define-vop (digit-lshr)
+  (:translate bignum::%digit-logical-shift-right)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg))
+	 (count :scs (unsigned-reg)))
+  (:arg-types unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 2
+    (inst mtctl count :sar)
+    (inst shd zero-tn digit :variable result)))
+
+(define-vop (digit-ashr digit-lshr)
+  (:translate bignum::%ashr)
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+  (:generator 1
+    (inst extrs digit 0 1 temp)
+    (inst mtctl count :sar)
+    (inst shd temp digit :variable result)))
+
+(define-vop (digit-ashl digit-ashr)
+  (:translate bignum::%ashl)
+  (:generator 1
+    (inst subi 31 count temp)
+    (inst mtctl temp :sar)
+    (inst zdep digit :variable 32 result)))
+
+
+;;;; Static functions.
+
+(define-static-function two-arg-gcd (x y) :translate gcd)
+(define-static-function two-arg-lcm (x y) :translate lcm)
+
+(define-static-function two-arg-* (x y) :translate *)
+(define-static-function two-arg-/ (x y) :translate /)
+
+(define-static-function %negate (x) :translate %negate)
+
+(define-static-function two-arg-and (x y) :translate logand)
+(define-static-function two-arg-ior (x y) :translate logior)
+(define-static-function two-arg-xor (x y) :translate logxor)
diff --git a/compiler/hppa/array.lisp b/compiler/hppa/array.lisp
new file mode 100644
index 000000000..de69676cc
--- /dev/null
+++ b/compiler/hppa/array.lisp
@@ -0,0 +1,348 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/array.lisp,v 1.1 1992/07/13 03:48:16 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the SPARC definitions for array operations.
+;;;
+;;; Written by William Lott
+;;;
+(in-package "HPPA")
+
+
+;;;; Allocator for the array header.
+
+(define-vop (make-array-header)
+  (:translate make-array-header)
+  (:policy :fast-safe)
+  (:args (type :scs (any-reg))
+	 (rank :scs (any-reg)))
+  (:arg-types tagged-num tagged-num)
+  (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
+  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 0
+    (pseudo-atomic ()
+      (inst move alloc-tn header)
+      (inst dep other-pointer-type 31 3 header)
+      (inst addi (* (1+ array-dimensions-offset) word-bytes) ndescr rank)
+      (inst dep 0 31 3 ndescr)
+      (inst add alloc-tn ndescr alloc-tn)
+      (inst addi (fixnum (1- array-dimensions-offset)) rank ndescr)
+      (inst sll ndescr type-bits ndescr)
+      (inst or ndescr type ndescr)
+      (inst srl ndescr 2 ndescr)
+      (storew ndescr header 0 vm:other-pointer-type))
+    (move header result)))
+
+
+;;;; Additional accessors and setters for the array header.
+
+(defknown lisp::%array-dimension (t index) index
+  (flushable))
+(defknown lisp::%set-array-dimension (t index index) index
+  ())
+
+(define-full-reffer %array-dimension *
+  array-dimensions-offset other-pointer-type
+  (any-reg) positive-fixnum lisp::%array-dimension)
+
+(define-full-setter %set-array-dimension *
+  array-dimensions-offset other-pointer-type
+  (any-reg) positive-fixnum lisp::%set-array-dimension)
+
+
+(defknown lisp::%array-rank (t) index (flushable))
+
+(define-vop (array-rank-vop)
+  (:translate lisp::%array-rank)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (loadw res x 0 vm:other-pointer-type)
+    (inst srl res type-bits res)
+    (inst addi (- (1- vm:array-dimensions-offset)) res res)))
+
+
+
+;;;; Bounds checking routine.
+
+
+(define-vop (check-bound)
+  (:translate %check-bound)
+  (:policy :fast-safe)
+  (:args (array :scs (descriptor-reg))
+	 (bound :scs (any-reg descriptor-reg))
+	 (index :scs (any-reg descriptor-reg) :target result))
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+    (let ((error (generate-error-code vop invalid-array-index-error
+				      array bound index)))
+      (inst bc :>= nil index bound error))
+    (move index result)))
+
+
+;;;; Accessors/Setters
+
+;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
+;;; elements are represented in integer registers and are built out of
+;;; 8, 16, or 32 bit elements.
+
+(eval-when (compile eval)
+
+(defmacro def-full-data-vector-frobs (type element-type &rest scs)
+  `(progn
+     (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-ref)
+     (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-set)))
+
+(defmacro def-partial-data-vector-frobs
+	  (type element-type size signed &rest scs)
+  `(progn
+     (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+       ,size ,signed vector-data-offset other-pointer-type ,scs
+       ,element-type data-vector-ref)
+     (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+       ,size vector-data-offset other-pointer-type ,scs
+       ,element-type data-vector-set)))
+
+); eval-when (compile eval)
+
+(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
+
+(def-partial-data-vector-frobs simple-string base-char :byte :leave-alone
+  base-char-reg)
+
+(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
+  :byte nil unsigned-reg signed-reg)
+
+(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
+  :short nil unsigned-reg signed-reg)
+
+(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
+  unsigned-reg)
+
+
+;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
+;;; and 4-bit vectors.
+;;; 
+
+(eval-when (compile eval)
+
+(defmacro def-small-data-vector-frobs (type bits)
+  (let* ((elements-per-word (floor vm:word-bits bits))
+	 (bit-shift (1- (integer-length elements-per-word))))
+    `(progn
+       (define-vop (,(symbolicate 'data-vector-ref/ type))
+	 (:note "inline array access")
+	 (:translate data-vector-ref)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(index :scs (unsigned-reg)))
+	 (:arg-types ,type positive-fixnum)
+	 (:results (result :scs (unsigned-reg) :from (:argument 0)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (non-descriptor-reg)) temp)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:generator 20
+	   (inst srl index ,bit-shift temp)
+	   (inst sh2add temp object lip)
+	   (loadw result lip vector-data-offset other-pointer-type)
+	   (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
+	   ,@(unless (= bits 1)
+	       `((inst addi ,(1- bits) temp temp)))
+	   (inst mtctl temp :sar)
+	   (inst extru result :variable ,bits result)))
+       (define-vop (,(symbolicate 'data-vector-ref-c/ type))
+	 (:translate data-vector-ref)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg)))
+	 (:arg-types ,type (:constant index))
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (non-descriptor-reg)) temp)
+	 (:generator 15
+	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
+			      vm:other-pointer-type)))
+	       (cond ((typep offset '(signed-byte 14))
+		      (inst ldw offset object result))
+		     (t
+		      (inst ldil (ldb (byte 21 11) offset) temp)
+		      (inst ldw (ldb (byte 11 0) offset) temp result))))
+	     (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result))))
+       (define-vop (,(symbolicate 'data-vector-set/ type))
+	 (:note "inline array store")
+	 (:translate data-vector-set)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(index :scs (unsigned-reg))
+		(value :scs (unsigned-reg zero immediate) :target result))
+	 (:arg-types ,type positive-fixnum positive-fixnum)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (non-descriptor-reg)) temp old)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:generator 25
+	   (inst srl index ,bit-shift temp)
+	   (inst sh2add temp object lip)
+	   (loadw old lip vector-data-offset other-pointer-type)
+	   (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
+	   ,@(unless (= bits 1)
+	       `((inst addi ,(1- bits) temp temp)))
+	   (inst mtctl temp :sar)
+	   (inst dep (sc-case value (immediate (tn-value value)) (t value))
+		 :variable ,bits old)
+	   (storew old lip vector-data-offset other-pointer-type)
+	   (sc-case value
+	     (immediate
+	      (inst li (tn-value value) result))
+	     (t
+	      (move value result)))))
+       (define-vop (,(symbolicate 'data-vector-set-c/ type))
+	 (:translate data-vector-set)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(value :scs (unsigned-reg zero immediate) :target result))
+	 (:arg-types ,type
+		     (:constant index)
+		     positive-fixnum)
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (non-descriptor-reg)) old)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:generator 20
+	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	     (let ((offset (- (* (+ word vector-data-offset) word-bytes)
+			      other-pointer-type)))
+	       (cond ((typep offset '(signed-byte 14))
+		      (inst ldw offset object old))
+		     (t
+		      (inst move object lip)
+		      (inst addil (ldb (byte 21 11) offset) lip)
+		      (inst ldw (ldb (byte 11 0) offset) lip old)))
+	       (inst dep (sc-case value
+			   (immediate (tn-value value))
+			   (t value))
+		     (+ (* extra ,bits) ,(1- bits))
+		     ,bits
+		     old)
+	       (if (typep offset '(signed-byte 14))
+		   (inst stw old offset object)
+		   (inst stw old (ldb (byte 11 0) offset) lip)))
+	     (sc-case value
+	       (immediate
+		(inst li (tn-value value) result))
+	       (t
+		(move value result)))))))))
+
+); eval-when (compile eval)
+
+(def-small-data-vector-frobs simple-bit-vector 1)
+(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
+(def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
+
+;;; And the float variants.
+;;; 
+
+(define-vop (data-vector-ref/simple-array-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:argument 1))
+	 (index :scs (any-reg) :to (:argument 0) :target offset))
+  (:arg-types simple-array-single-float positive-fixnum)
+  (:results (value :scs (single-reg)))
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
+  (:result-types single-float)
+  (:generator 5
+    (inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
+	  index offset)
+    (inst fldx offset object value)))
+
+(define-vop (data-vector-set/simple-array-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:argument 1))
+	 (index :scs (any-reg) :to (:argument 0) :target offset)
+	 (value :scs (single-reg) :target result))
+  (:arg-types simple-array-single-float positive-fixnum single-float)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
+  (:generator 5
+    (inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
+	  index offset)
+    (inst fstx value offset object)
+    (unless (location= result value)
+      (inst funop :copy value result))))
+
+(define-vop (data-vector-ref/simple-array-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:argument 1))
+	 (index :scs (any-reg) :to (:argument 0) :target offset))
+  (:arg-types simple-array-double-float positive-fixnum)
+  (:results (value :scs (double-reg)))
+  (:result-types double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
+  (:generator 7
+    (inst sll index 1 offset)
+    (inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
+	  offset offset)
+    (inst fldx offset object value)))
+
+(define-vop (data-vector-set/simple-array-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:argument 1))
+	 (index :scs (any-reg) :to (:argument 0) :target offset)
+	 (value :scs (double-reg) :target result))
+  (:arg-types simple-array-double-float positive-fixnum double-float)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
+  (:generator 20
+    (inst sll index 1 offset)
+    (inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
+	  offset offset)
+    (inst fstx value offset object)
+    (unless (location= result value)
+      (inst funop :copy value result))))
+
+;;; These vops are useful for accessing the bits of a vector irrespective of
+;;; what type of vector it is.
+;;; 
+
+(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num
+  %raw-bits)
+(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
+  unsigned-num %set-raw-bits)
+
+
+
+;;;; Misc. Array VOPs.
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
+
diff --git a/compiler/hppa/c-call.lisp b/compiler/hppa/c-call.lisp
new file mode 100644
index 000000000..314babac6
--- /dev/null
+++ b/compiler/hppa/c-call.lisp
@@ -0,0 +1,185 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/c-call.lisp,v 1.1 1992/07/13 03:48:17 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and other necessary machine specific support
+;;; routines for call-out to C.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "HPPA")
+(use-package "ALIEN")
+(use-package "ALIEN-INTERNALS")
+
+(defun my-make-wired-tn (prim-type-name sc-name offset)
+  (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
+		 (sc-number-or-lose sc-name *backend*)
+		 offset))
+
+(defstruct arg-state
+  (args 0))
+
+(defstruct (arg-info
+	    (:constructor make-arg-info (offset prim-type reg-sc stack-sc)))
+  offset
+  prim-type
+  reg-sc
+  stack-sc)
+
+(def-alien-type-method (integer :arg-tn) (type state)
+  (let ((args (arg-state-args state)))
+    (setf (arg-state-args state) (1+ args))
+    (if (alien-integer-type-signed type)
+	(make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack)
+	(make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))))
+
+(def-alien-type-method (system-area-pointer :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((args (arg-state-args state)))
+    (setf (arg-state-args state) (1+ args))
+    (make-arg-info args 'system-area-pointer 'sap-reg 'sap-stack)))
+
+(def-alien-type-method (single-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((args (arg-state-args state)))
+    (setf (arg-state-args state) (1+ args))
+    (make-arg-info args 'single-float 'single-reg 'single-stack)))
+
+(def-alien-type-method (double-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((args (logior (1+ (arg-state-args state)) 1)))
+    (setf (arg-state-args state) (1+ args))
+    (make-arg-info args 'double-float 'double-reg 'double-stack)))
+
+(def-alien-type-method (integer :result-tn) (type)
+  (if (alien-integer-type-signed type)
+      (my-make-wired-tn 'signed-byte-32 'signed-reg nl4-offset)
+      (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl4-offset)))
+  
+(def-alien-type-method (system-area-pointer :result-tn) (type)
+  (declare (ignore type))
+  (my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset))
+
+(def-alien-type-method (single-float :result-tn) (type)
+  (declare (ignore type))
+  (my-make-wired-tn 'single-float 'single-reg 4))
+
+(def-alien-type-method (double-float :result-tn) (type)
+  (declare (ignore type))
+  (my-make-wired-tn 'double-float 'double-reg 4))
+
+(def-alien-type-method (values :result-tn) (type)
+  (let ((values (alien-values-type-values type)))
+    (when values
+      (assert (null (cdr values)))
+      (invoke-alien-type-method :result-tn (car values)))))
+
+(defun make-argument-tns (type)
+  (let* ((state (make-arg-state))
+	 (args (mapcar #'(lambda (arg-type)
+			   (invoke-alien-type-method :arg-tn arg-type state))
+		       (alien-function-type-arg-types type)))
+	 ;; We need 8 words of cruft, and we need to round up to a multiple
+	 ;; of 16 words.
+	 (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15)))
+    (values
+     (mapcar #'(lambda (arg)
+		 (declare (type arg-info arg))
+		 (let ((offset (arg-info-offset arg))
+		       (prim-type (arg-info-prim-type arg)))
+		   (cond ((>= offset 4)
+			  (my-make-wired-tn prim-type (arg-info-stack-sc arg)
+					    (- frame-size offset 8 1)))
+			 ((or (eq prim-type 'single-float)
+			      (eq prim-type 'double-float))
+			  (my-make-wired-tn prim-type (arg-info-reg-sc arg)
+					    (+ offset 4)))
+			 (t
+			  (my-make-wired-tn prim-type (arg-info-reg-sc arg)
+					    (- nl0-offset offset))))))
+	     args)
+     (* frame-size word-bytes))))
+
+(def-vm-support-routine make-call-out-tns (type)
+  (declare (type alien-function-type type))
+  (multiple-value-bind
+      (arg-tns stack-size)
+      (make-argument-tns type)
+    (values (make-normal-tn *fixnum-primitive-type*)
+	    stack-size
+	    arg-tns
+	    (invoke-alien-type-method
+	     :result-tn
+	     (alien-function-type-result-type type)))))
+
+
+(define-vop (foreign-symbol-address)
+  (:translate foreign-symbol-address)
+  (:policy :fast-safe)
+  (:args)
+  (:arg-types (:constant simple-string))
+  (:info foreign-symbol)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 2
+    (inst li (make-fixup foreign-symbol :foreign) res)))
+
+(define-vop (call-out)
+  (:args (function :scs (sap-reg) :target cfunc)
+	 (args :more t))
+  (:results (results :more t))
+  (:ignore args results)
+  (:save-p t)
+  (:temporary (:sc any-reg :offset cfunc-offset
+		   :from (:argument 0) :to (:result 0)) cfunc)
+  (:temporary (:scs (any-reg) :to (:result 0)) temp)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:vop-var vop)
+  (:generator 0
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (move function cfunc)
+      (let ((fixup (make-fixup "call_into_c" :foreign)))
+	(inst ldil fixup temp)
+	(inst ble fixup c-text-space temp :nullify t))
+      (inst nop)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))))
+
+
+(define-vop (alloc-number-stack-space)
+  (:info amount)
+  (:results (result :scs (sap-reg any-reg)))
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+  (:generator 0
+    (move nsp-tn result)
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 63) 63)))
+	(cond ((< delta (ash 1 10))
+	       (inst addi delta nsp-tn nsp-tn))
+	      (t
+	       (inst li delta temp)
+	       (inst add temp nsp-tn nsp-tn)))))))
+
+(define-vop (dealloc-number-stack-space)
+  (:info amount)
+  (:policy :fast-safe)
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+  (:generator 0
+    (unless (zerop amount)
+      (let ((delta (- (logandc2 (+ amount 63) 63))))
+	(cond ((<= (- (ash 1 10)) delta)
+	       (inst addi delta nsp-tn nsp-tn))
+	      (t
+	       (inst li delta temp)
+	       (inst add temp nsp-tn nsp-tn)))))))
diff --git a/compiler/hppa/call.lisp b/compiler/hppa/call.lisp
new file mode 100644
index 000000000..c63c5a859
--- /dev/null
+++ b/compiler/hppa/call.lisp
@@ -0,0 +1,1219 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/call.lisp,v 1.1 1992/07/13 03:48:18 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of function call for the HPPA.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "HPPA")
+
+
+;;;; Interfaces to IR2 conversion:
+
+;;; Standard-Argument-Location  --  Interface
+;;;
+;;;    Return a wired TN describing the N'th full call argument passing
+;;; location.
+;;;
+(def-vm-support-routine standard-argument-location (n)
+  (declare (type unsigned-byte n))
+  (if (< n register-arg-count)
+      (make-wired-tn *any-primitive-type*
+		     register-arg-scn
+		     (elt register-arg-offsets n))
+      (make-wired-tn *any-primitive-type*
+		     control-stack-arg-scn n)))
+
+
+;;; Make-Return-PC-Passing-Location  --  Interface
+;;;
+;;;    Make a passing location TN for a local call return PC.  If standard is
+;;; true, then use the standard (full call) location, otherwise use any legal
+;;; location.  Even in the non-standard case, this may be restricted by a
+;;; desire to use a subroutine call instruction.
+;;;
+(def-vm-support-routine make-return-pc-passing-location (standard)
+  (if standard
+      (make-wired-tn *any-primitive-type* register-arg-scn lra-offset)
+      (make-restricted-tn *any-primitive-type* register-arg-scn)))
+
+;;; Make-Old-FP-Passing-Location  --  Interface
+;;;
+;;;    Similar to Make-Return-PC-Passing-Location, but makes a location to pass
+;;; Old-FP in.  This is (obviously) wired in the standard convention, but is
+;;; totally unrestricted in non-standard conventions, since we can always fetch
+;;; it off of the stack using the arg pointer.
+;;;
+(def-vm-support-routine make-old-fp-passing-location (standard)
+  (if standard
+      (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
+      (make-normal-tn *fixnum-primitive-type*)))
+
+;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location  --  Interface
+;;;
+;;;    Make the TNs used to hold Old-FP and Return-PC within the current
+;;; function.  We treat these specially so that the debugger can find them at a
+;;; known location.
+;;;
+(def-vm-support-routine make-old-fp-save-location (env)
+  (specify-save-tn
+   (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
+   (make-wired-tn *fixnum-primitive-type*
+		  control-stack-arg-scn
+		  ocfp-save-offset)))
+;;;
+(def-vm-support-routine make-return-pc-save-location (env)
+  (specify-save-tn
+   (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env)
+   (make-wired-tn *any-primitive-type*
+		  control-stack-arg-scn
+		  lra-save-offset)))
+
+;;; Make-Argument-Count-Location  --  Interface
+;;;
+;;;    Make a TN for the standard argument count passing location.  We only
+;;; need to make the standard location, since a count is never passed when we
+;;; are using non-standard conventions.
+;;;
+(def-vm-support-routine make-argument-count-location ()
+  (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
+
+
+;;; MAKE-NFP-TN  --  Interface
+;;;
+;;;    Make a TN to hold the number-stack frame pointer.  This is allocated
+;;; once per component, and is component-live.
+;;;
+(def-vm-support-routine make-nfp-tn ()
+  (component-live-tn
+   (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset)))
+
+;;; MAKE-STACK-POINTER-TN ()
+;;; 
+(def-vm-support-routine make-stack-pointer-tn ()
+  (make-normal-tn *fixnum-primitive-type*))
+
+;;; MAKE-NUMBER-STACK-POINTER-TN ()
+;;; 
+(def-vm-support-routine make-number-stack-pointer-tn ()
+  (make-normal-tn *fixnum-primitive-type*))
+
+;;; Make-Unknown-Values-Locations  --  Interface
+;;;
+;;;    Return a list of TNs that can be used to represent an unknown-values
+;;; continuation within a function.
+;;;
+(def-vm-support-routine make-unknown-values-locations ()
+  (list (make-stack-pointer-tn)
+	(make-normal-tn *fixnum-primitive-type*)))
+
+
+;;; Select-Component-Format  --  Interface
+;;;
+;;;    This function is called by the Entry-Analyze phase, allowing
+;;; VM-dependent initialization of the IR2-Component structure.  We push
+;;; placeholder entries in the Constants to leave room for additional
+;;; noise in the code object header.
+;;;
+(def-vm-support-routine select-component-format (component)
+  (declare (type component component))
+  (dotimes (i code-constants-offset)
+    (vector-push-extend nil
+			(ir2-component-constants (component-info component))))
+  (undefined-value))
+
+
+;;;; Frame hackery:
+
+;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal
+;;;
+;;; Return the number of bytes needed for the current non-descriptor stack.
+;;; We have to allocate multiples of 64 bytes.
+;;; 
+(defun bytes-needed-for-non-descriptor-stack-frame ()
+  (logandc2 (+ (* (sb-allocated-size 'non-descriptor-stack) word-bytes) 63)
+	    63))
+
+;;; Used for setting up the Old-FP in local call.
+;;;
+(define-vop (current-fp)
+  (:results (val :scs (any-reg)))
+  (:generator 1
+    (move cfp-tn val)))
+
+;;; Used for computing the caller's NFP for use in known-values return.  Only
+;;; works assuming there is no variable size stuff on the nstack.
+;;;
+(define-vop (compute-old-nfp)
+  (:results (val :scs (any-reg)))
+  (:vop-var vop)
+  (:generator 1
+    (let ((nfp (current-nfp-tn vop)))
+      (when nfp
+	(inst addi (- (bytes-needed-for-non-descriptor-stack-frame))
+	      val nfp)))))
+
+(define-vop (xep-allocate-frame)
+  (:info start-lab)
+  (:vop-var vop)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 1
+    ;; Make sure the function is aligned, and drop a label pointing to this
+    ;; function header.
+    (align lowtag-bits)
+    (trace-table-entry trace-table-function-prologue)
+    (emit-label start-lab)
+    ;; Allocate function header.
+    (inst function-header-word)
+    (dotimes (i (1- function-header-code-offset))
+      (inst word 0))
+    ;; The start of the actual code.
+    ;; Fix CODE, cause the function object was passed in.
+    (let ((entry-point (gen-label)))
+      (emit-label entry-point)
+      (inst compute-code-from-fn lip-tn entry-point temp code-tn))
+    ;; Build our stack frames.
+    (inst addi (* vm:word-bytes (sb-allocated-size 'control-stack))
+	  cfp-tn csp-tn)
+    (let ((nfp (current-nfp-tn vop)))
+      (when nfp
+	(move nsp-tn nfp)
+	(inst addi (bytes-needed-for-non-descriptor-stack-frame)
+	      nsp-tn nsp-tn)))
+    (trace-table-entry trace-table-normal)))
+
+(define-vop (allocate-frame)
+  (:results (res :scs (any-reg))
+	    (nfp :scs (any-reg)))
+  (:info callee)
+  (:generator 2
+    (move csp-tn res)
+    (inst addi (* vm:word-bytes (sb-allocated-size 'control-stack))
+	  csp-tn csp-tn)
+    (when (ir2-environment-number-stack-p callee)
+      (move nsp-tn nfp)
+      (inst addi (- (bytes-needed-for-non-descriptor-stack-frame))
+	    nsp-tn nsp-tn))))
+
+;;; Allocate a partial frame for passing stack arguments in a full call.  Nargs
+;;; is the number of arguments passed.  If no stack arguments are passed, then
+;;; we don't have to do anything.
+;;;
+(define-vop (allocate-full-call-frame)
+  (:info nargs)
+  (:results (res :scs (any-reg)))
+  (:generator 2
+    (when (> nargs register-arg-count)
+      (move csp-tn res)
+      (inst addi (* nargs vm:word-bytes) csp-tn csp-tn))))
+
+
+;;; Default-Unknown-Values  --  Internal
+;;;
+;;;    Emit code needed at the return-point from an unknown-values call for a
+;;; fixed number of values.  Values is the head of the TN-Ref list for the
+;;; locations that the values are to be received into.  Nvals is the number of
+;;; values that are to be received (should equal the length of Values).
+;;;
+;;;    Move-Temp is a Descriptor-Reg TN used as a temporary.
+;;;
+;;;    This code exploits the fact that in the unknown-values convention, a
+;;; single value return returns at the return PC + 8, whereas a return of other
+;;; than one value returns directly at the return PC.
+;;;
+;;;    If 0 or 1 values are expected, then we just emit an instruction to reset
+;;; the SP (which will only be executed when other than 1 value is returned.)
+;;;
+;;; In the general case, we have to do three things:
+;;;  -- Default unsupplied register values.  This need only be done when a
+;;;     single value is returned, since register values are defaulted by the
+;;;     called in the non-single case.
+;;;  -- Default unsupplied stack values.  This needs to be done whenever there
+;;;     are stack values.
+;;;  -- Reset SP.  This must be done whenever other than 1 value is returned,
+;;;     regardless of the number of values desired.
+;;;
+;;; The general-case code looks like this:
+#|
+	b regs-defaulted		; Skip if MVs
+	nop
+
+	move a1 null-tn			; Default register values
+	...
+	loadi nargs 1			; Force defaulting of stack values
+	move old-fp csp			; Set up args for SP resetting
+
+regs-defaulted
+	subu temp nargs register-arg-count
+
+	bltz temp default-value-7	; jump to default code
+        addu temp temp -1
+	loadw move-temp old-fp-tn 6	; Move value to correct location.
+	store-stack-tn val4-tn move-temp
+
+	bltz temp default-value-8
+        addu temp temp -1
+	loadw move-temp old-fp-tn 7
+	store-stack-tn val5-tn move-temp
+
+	...
+
+defaulting-done
+	move sp old-fp			; Reset SP.
+<end of code>
+
+<elsewhere>
+default-value-7
+	store-stack-tn val4-tn null-tn	; Nil out 7'th value. (first on stack)
+
+default-value-8
+	store-stack-tn val5-tn null-tn	; Nil out 8'th value.
+
+	...
+
+	br defaulting-done
+        nop
+|#
+;;;
+(defun default-unknown-values (vop values nvals move-temp temp lra-label)
+  (declare (type (or tn-ref null) values)
+	   (type unsigned-byte nvals) (type tn move-temp temp))
+  (cond
+   ((<= nvals 1)
+    (assemble ()
+      ;; Note that this is a single-value return point.  This is actually
+      ;; the multiple-value entry point for a single desired value, but
+      ;; the code location has to be here, or the debugger backtrace
+      ;; gets confused.
+      (note-this-location vop :single-value-return)
+      (move ocfp-tn csp-tn)
+      (inst compute-code-from-lra code-tn lra-label temp code-tn)))
+   ((<= nvals register-arg-count)
+    (assemble ()
+      ;; Note that this is an unknown-values return point.
+      (note-this-location vop :unknown-return)
+      ;; Branch off to the MV case.
+      (inst b regs-defaulted :nullify t)
+	
+      ;; Default any unsupplied values.
+      (do ((val (tn-ref-across values) (tn-ref-across val)))
+	  ((null val))
+	(inst move null-tn (tn-ref-tn val)
+	      (if (tn-ref-across val)
+		  :never
+		  :tr)))
+
+      REGS-DEFAULTED
+
+      ;; Clear the stack.  Note: the last move in the single value reg
+      ;; defaulting nullifies this, so this only happens in the mv case.
+      (move ocfp-tn csp-tn)
+
+      ;; Fix CODE.
+      (inst compute-code-from-lra code-tn lra-label temp code-tn)))
+   (t
+    (collect ((defaults))
+      (assemble (nil nil :labels (default-stack-vals))
+	;; Note that this is an unknown-values return point.
+	(note-this-location vop :unknown-return)
+	;; Branch off to the MV case.
+	(inst b regs-defaulted :nullify t)
+	
+	;; Default any unsupplied register values.
+	(do ((i 1 (1+ i))
+	     (val (tn-ref-across values) (tn-ref-across val)))
+	    ((= i register-arg-count))
+	  (inst move null-tn (tn-ref-tn val)))
+	(inst b default-stack-vals)
+	(move ocfp-tn csp-tn)
+	
+	REGS-DEFAULTED
+	
+	(do ((i register-arg-count (1+ i))
+	     (val (do ((i 0 (1+ i))
+		       (val values (tn-ref-across val)))
+		      ((= i register-arg-count) val))
+		  (tn-ref-across val)))
+	    ((null val))
+	  
+	  (let ((default-lab (gen-label))
+		(tn (tn-ref-tn val)))
+	    (defaults (cons default-lab tn))
+	    (inst bci :> nil (fixnum i) nargs-tn default-lab)
+	    (loadw move-temp ocfp-tn i)
+	    (store-stack-tn tn move-temp)))
+	
+	DEFAULTING-DONE
+	(move ocfp-tn csp-tn)
+	(inst compute-code-from-lra code-tn lra-label temp code-tn)
+	
+	(let ((defaults (defaults)))
+	  (assert defaults)
+	  (assemble (*elsewhere*)
+	    (trace-table-entry trace-table-call-site)
+	    DEFAULT-STACK-VALS
+	    (do ((remaining defaults (cdr remaining)))
+		((null remaining))
+	      (let ((def (car remaining)))
+		(emit-label (car def))
+		(when (null (cdr remaining))
+		  (inst b defaulting-done))
+		(store-stack-tn (cdr def) null-tn)))
+	    (trace-table-entry trace-table-normal)))))))
+  (undefined-value))
+
+
+;;;; Unknown values receiving:
+
+;;; Receive-Unknown-Values  --  Internal
+;;;
+;;;    Emit code needed at the return point for an unknown-values call for an
+;;; arbitrary number of values.
+;;;
+;;;    We do the single and non-single cases with no shared code: there doesn't
+;;; seem to be any potential overlap, and receiving a single value is more
+;;; important efficiency-wise.
+;;;
+;;;    When there is a single value, we just push it on the stack, returning
+;;; the old SP and 1.
+;;;
+;;;    When there is a variable number of values, we move all of the argument
+;;; registers onto the stack, and return Args and Nargs.
+;;;
+;;;    Args and Nargs are TNs wired to the named locations.  We must
+;;; explicitly allocate these TNs, since their lifetimes overlap with the
+;;; results Start and Count (also, it's nice to be able to target them).
+;;;
+(defun receive-unknown-values (args nargs start count lra-label temp)
+  (declare (type tn args nargs start count temp))
+  (assemble (nil nil :labels (variable-values))
+    (inst b variable-values :nullify t)
+      
+    (inst compute-code-from-lra code-tn lra-label temp code-tn)
+    (inst move csp-tn start)
+    (inst stwm (first register-arg-tns) word-bytes csp-tn)
+    (inst li (fixnum 1) count)
+    
+    DONE
+    
+    (assemble (*elsewhere*)
+      (trace-table-entry trace-table-call-site)
+      VARIABLE-VALUES
+      (inst compute-code-from-lra code-tn lra-label temp code-tn)
+      (do ((arg register-arg-tns (rest arg))
+	   (i 0 (1+ i)))
+	  ((null arg))
+	(storew (first arg) args i))
+      (move args start)
+      (move nargs count)
+      (inst b done :nullify t)
+      (trace-table-entry trace-table-normal)))
+  (undefined-value))
+
+;;; VOP that can be inherited by unknown values receivers.  The main thing this
+;;; handles is allocation of the result temporaries.
+;;;
+(define-vop (unknown-values-receiver)
+  (:results (start :scs (any-reg))
+	    (count :scs (any-reg)))
+  (:temporary (:sc descriptor-reg :offset ocfp-offset
+		   :from :eval :to (:result 0))
+	      values-start)
+  (:temporary (:sc any-reg :offset nargs-offset
+	       :from :eval :to (:result 1))
+	      nvals)
+  (:temporary (:scs (non-descriptor-reg)) temp))
+
+
+
+;;;; Local call with unknown values convention return:
+
+;;; Non-TR local call for a fixed number of values passed according to the
+;;; unknown values convention.
+;;;
+;;; Args are the argument passing locations, which are specified only to
+;;; terminate their lifetimes in the caller.
+;;;
+;;; Values are the return value locations (wired to the standard passing
+;;; locations).
+;;;
+;;; Save is the save info, which we can ignore since saving has been done.
+;;; Return-PC is the TN that the return PC should be passed in.
+;;; Target is a continuation pointing to the start of the called function.
+;;; Nvals is the number of values received.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand.  Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (call-local)
+  (:args (cfp)
+	 (nfp)
+	 (args :more t))
+  (:results (values :more t))
+  (:save-p t)
+  (:move-args :local-call)
+  (:info arg-locs callee target nvals)
+  (:vop-var vop)
+  (:temporary (:scs (descriptor-reg) :from :eval) move-temp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp)
+  (:ignore arg-locs args ocfp)
+  (:generator 5
+    (trace-table-entry trace-table-call-site)
+    (let ((label (gen-label))
+	  (cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (let ((callee-nfp (callee-nfp-tn callee)))
+	(when callee-nfp
+	  (move nfp callee-nfp)))
+      (maybe-load-stack-tn cfp-tn cfp)
+      (inst compute-lra-from-code code-tn label temp
+	    (callee-return-pc-tn callee))
+      (note-this-location vop :call-site)
+      (inst b target :nullify t)
+      (emit-return-pc label)
+      (default-unknown-values vop values nvals move-temp temp label)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))
+    (trace-table-entry trace-table-normal)))
+
+;;; Non-TR local call for a variable number of return values passed according
+;;; to the unknown values convention.  The results are the start of the values
+;;; glob and the number of values received.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand.  Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (multiple-call-local unknown-values-receiver)
+  (:args (cfp)
+	 (nfp)
+	 (args :more t))
+  (:save-p t)
+  (:move-args :local-call)
+  (:info save callee target)
+  (:ignore args save)
+  (:vop-var vop)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:generator 20
+    (trace-table-entry trace-table-call-site)
+    (let ((label (gen-label))
+	  (cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (let ((callee-nfp (callee-nfp-tn callee)))
+	(when callee-nfp
+	  (move nfp callee-nfp)))
+      (maybe-load-stack-tn cfp-tn cfp)
+      (inst compute-lra-from-code code-tn label temp
+	    (callee-return-pc-tn callee))
+      (note-this-location vop :call-site)
+      (inst b target :nullify t)
+      (emit-return-pc label)
+      (note-this-location vop :unknown-return)
+      (receive-unknown-values values-start nvals start count label temp)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))
+    (trace-table-entry trace-table-normal)))
+
+
+;;;; Local call with known values return:
+
+;;; Non-TR local call with known return locations.  Known-value return works
+;;; just like argument passing in local call.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand.  Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (known-call-local)
+  (:args (cfp)
+	 (nfp)
+	 (args :more t))
+  (:results (res :more t))
+  (:move-args :local-call)
+  (:save-p t)
+  (:info save callee target)
+  (:ignore args res save)
+  (:vop-var vop)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 5
+    (trace-table-entry trace-table-call-site)
+    (let ((label (gen-label))
+	  (cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (let ((callee-nfp (callee-nfp-tn callee)))
+	(when callee-nfp
+	  (move nfp callee-nfp)))
+      (maybe-load-stack-tn cfp-tn cfp)
+      (inst compute-lra-from-code code-tn label temp
+	    (callee-return-pc-tn callee))
+      (note-this-location vop :call-site)
+      (inst b target :nullify t)
+      (emit-return-pc label)
+      (note-this-location vop :known-return)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))
+    (trace-table-entry trace-table-normal)))
+
+;;; Return from known values call.  We receive the return locations as
+;;; arguments to terminate their lifetimes in the returning function.  We
+;;; restore FP and CSP and jump to the Return-PC.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand.  Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (known-return)
+  (:args (old-fp :target old-fp-temp)
+	 (return-pc :target return-pc-temp)
+	 (vals :more t))
+  (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
+  (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
+  (:temporary (:scs (interior-reg)) lip)
+  (:move-args :known-return)
+  (:info val-locs)
+  (:ignore val-locs vals)
+  (:vop-var vop)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    (maybe-load-stack-tn old-fp-temp old-fp)
+    (maybe-load-stack-tn return-pc-temp return-pc)
+    (move cfp-tn csp-tn)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addi (- (bytes-needed-for-non-descriptor-stack-frame))
+	      nsp-tn cur-nfp)))
+    (inst addi (- word-bytes other-pointer-type) return-pc-temp lip)
+    (inst bv lip)
+    (move old-fp-temp cfp-tn)
+    (trace-table-entry trace-table-normal)))
+
+
+;;;; Full call:
+;;;
+;;;    There is something of a cross-product effect with full calls.  Different
+;;; versions are used depending on whether we know the number of arguments or
+;;; the name of the called function, and whether we want fixed values, unknown
+;;; values, or a tail call.
+;;;
+;;; In full call, the arguments are passed creating a partial frame on the
+;;; stack top and storing stack arguments into that frame.  On entry to the
+;;; callee, this partial frame is pointed to by FP.  If there are no stack
+;;; arguments, we don't bother allocating a partial frame, and instead set FP
+;;; to SP just before the call.
+
+;;; Define-Full-Call  --  Internal
+;;;
+;;;    This macro helps in the definition of full call VOPs by avoiding code
+;;; replication in defining the cross-product VOPs.
+;;;
+;;; Name is the name of the VOP to define.
+;;; 
+;;; Named is true if the first argument is a symbol whose global function
+;;; definition is to be called.
+;;;
+;;; Return is either :Fixed, :Unknown or :Tail:
+;;; -- If :Fixed, then the call is for a fixed number of values, returned in
+;;;    the standard passing locations (passed as result operands).
+;;; -- If :Unknown, then the result values are pushed on the stack, and the
+;;;    result values are specified by the Start and Count as in the
+;;;    unknown-values continuation representation.
+;;; -- If :Tail, then do a tail-recursive call.  No values are returned.
+;;;    The Old-Fp and Return-PC are passed as the second and third arguments.
+;;;
+;;; In non-tail calls, the pointer to the stack arguments is passed as the last
+;;; fixed argument.  If Variable is false, then the passing locations are
+;;; passed as a more arg.  Variable is true if there are a variable number of
+;;; arguments passed on the stack.  Variable cannot be specified with :Tail
+;;; return.  TR variable argument call is implemented separately.
+;;;
+;;; In tail call with fixed arguments, the passing locations are passed as a
+;;; more arg, but there is no new-FP, since the arguments have been set up in
+;;; the current frame.
+;;;
+(eval-when (compile eval)
+(defmacro define-full-call (name named return variable)
+  (assert (not (and variable (eq return :tail))))
+  `(define-vop (,name
+		,@(when (eq return :unknown)
+		    '(unknown-values-receiver)))
+     (:args
+      ,@(unless (eq return :tail)
+	  '((new-fp :scs (any-reg) :to :eval)))
+
+      ,(if named
+	   '(fdefn :target fdefn-pass)
+	   '(arg-fun :target lexenv))
+      
+      ,@(when (eq return :tail)
+	  '((ocfp :target ocfp-pass)
+	    (lra :target lra-pass)))
+      
+      ,@(unless variable '((args :more t :scs (descriptor-reg)))))
+
+     ,@(when (eq return :fixed)
+	 '((:results (values :more t))))
+   
+     (:save-p ,(if (eq return :tail) :compute-only t))
+
+     ,@(unless (or (eq return :tail) variable)
+	 '((:move-args :full-call)))
+
+     (:vop-var vop)
+     (:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
+	    ,@(unless variable '(nargs))
+	    ,@(when (eq return :fixed) '(nvals)))
+
+     (:ignore
+      ,@(unless (or variable (eq return :tail)) '(arg-locs))
+      ,@(unless variable '(args)))
+
+     (:temporary (:sc descriptor-reg
+		  :offset ocfp-offset
+		  ,@(when (eq return :tail)
+		      '(:from (:argument 1)))
+		  ,@(unless (eq return :fixed)
+		      '(:to :eval)))
+		 ocfp-pass)
+
+     (:temporary (:sc descriptor-reg
+		  :offset lra-offset
+		  ,@(when (eq return :tail)
+		      '(:from (:argument 2)))
+		  :to :eval)
+		 lra-pass)
+
+     ,@(if named
+	 `((:temporary (:sc descriptor-reg :offset fdefn-offset
+			:from (:argument ,(if (eq return :tail) 0 1))
+			:to :eval)
+		       fdefn-pass))
+
+	 `((:temporary (:sc descriptor-reg :offset lexenv-offset
+			:from (:argument ,(if (eq return :tail) 0 1))
+			:to :eval)
+		       lexenv)
+	   (:temporary (:scs (descriptor-reg)
+			     :from (:argument ,(if (eq return :tail) 2 1))
+			     :to :eval)
+		       function)))
+
+     (:temporary (:sc any-reg :offset nargs-offset :to :eval)
+		 nargs-pass)
+
+     ,@(when variable
+	 (mapcar #'(lambda (name offset)
+		     `(:temporary (:sc descriptor-reg
+				   :offset ,offset
+				   :to :eval)
+			 ,name))
+		 register-arg-names register-arg-offsets))
+     ,@(when (eq return :fixed)
+	 '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
+
+     ,@(unless (eq return :tail)
+	 '((:temporary (:scs (non-descriptor-reg)) temp)
+	   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
+
+     (:temporary (:scs (interior-reg) :type interior) lip)
+
+     (:generator ,(+ (if named 5 0)
+		     (if variable 19 1)
+		     (if (eq return :tail) 0 10)
+		     15
+		     (if (eq return :unknown) 25 0))
+       (trace-table-entry trace-table-call-site)
+       (let* ((cur-nfp (current-nfp-tn vop))
+	      ,@(unless (eq return :tail)
+		  '((lra-label (gen-label))))
+	      (filler
+	       (list :load-nargs
+		     ,@(if (eq return :tail)
+			   '((unless (location= ocfp ocfp-pass)
+			       :load-ocfp)
+			     (unless (location= lra lra-pass)
+			       :load-lra)
+			     (when cur-nfp
+			       :frob-nfp))
+			   '((when cur-nfp
+			       :frob-nfp)
+			     :comp-lra
+			     :save-fp
+			     :load-fp)))))
+	 (labels
+	     ((do-next-filler ()
+		(when filler
+		  (ecase (pop filler)
+		    ((nil) (do-next-filler))
+		    (:load-nargs
+		     ,@(if variable
+			   `((inst sub csp-tn new-fp nargs-pass)
+			     ,@(let ((index -1))
+				 (mapcar #'(lambda (name)
+					     `(loadw ,name new-fp
+						     ,(incf index)))
+					 register-arg-names)))
+			   '((inst li (fixnum nargs) nargs-pass))))
+		    ,@(if (eq return :tail)
+			  '((:load-ocfp
+			     (sc-case ocfp
+			       (any-reg
+				(inst move ocfp ocfp-pass))
+			       (control-stack
+				(loadw ocfp-pass cfp-tn (tn-offset ocfp)))))
+			    (:load-lra
+			     (sc-case lra
+			       (descriptor-reg
+				(inst move lra lra-pass))
+			       (control-stack
+				(loadw lra-pass cfp-tn (tn-offset lra)))))
+			    (:frob-nfp
+			     (inst move cur-nfp nsp-tn)))
+			  `((:frob-nfp
+			     (store-stack-tn nfp-save cur-nfp))
+			    (:comp-lra
+			     (inst compute-lra-from-code
+				   code-tn lra-label temp lra-pass))
+			    (:save-fp
+			     (inst move cfp-tn ocfp-pass))
+			    (:load-fp
+			     ,(if variable
+				  '(move new-fp cfp-tn)
+				  '(if (> nargs register-arg-count)
+				       (move new-fp cfp-tn)
+				       (move csp-tn cfp-tn))))))))))
+
+	   ,@(if named
+		 `((sc-case fdefn
+		     (descriptor-reg (move fdefn fdefn-pass))
+		     (control-stack
+		      (loadw fdefn-pass cfp-tn (tn-offset fdefn))
+		      (do-next-filler))
+		     (constant
+		      (loadw fdefn-pass code-tn (tn-offset fdefn)
+			     other-pointer-type)
+		      (do-next-filler)))
+		   (loadw lip fdefn-pass fdefn-raw-addr-slot
+			  other-pointer-type)
+		   (do-next-filler))
+		 `((sc-case arg-fun
+		     (descriptor-reg (move arg-fun lexenv))
+		     (control-stack
+		      (loadw lexenv cfp-tn (tn-offset arg-fun))
+		      (do-next-filler))
+		     (constant
+		      (loadw lexenv code-tn (tn-offset arg-fun)
+			     other-pointer-type)
+		      (do-next-filler)))
+		   (loadw function lexenv closure-function-slot
+			  function-pointer-type)
+		   (do-next-filler)
+		   (inst addi (- (ash function-header-code-offset word-shift)
+				 function-pointer-type)
+			 function lip)))
+	   (loop
+	     (cond ((null filler)
+		    (return))
+		   ((null (car filler))
+		    (pop filler))
+		   ((null (cdr filler))
+		    (return))
+		   (t
+		    (do-next-filler))))
+	   
+	   (note-this-location vop :call-site)
+	   (inst bv lip :nullify (null filler))
+	   (do-next-filler))
+
+	 ,@(ecase return
+	     (:fixed
+	      '((emit-return-pc lra-label)
+		(default-unknown-values vop values nvals
+					move-temp temp lra-label)
+		(when cur-nfp
+		  (load-stack-tn cur-nfp nfp-save))))
+	     (:unknown
+	      '((emit-return-pc lra-label)
+		(note-this-location vop :unknown-return)
+		(receive-unknown-values values-start nvals start count
+					lra-label temp)
+		(when cur-nfp
+		  (load-stack-tn cur-nfp nfp-save))))
+	     (:tail)))
+       (trace-table-entry trace-table-normal))))
+);eval-when
+
+(define-full-call call nil :fixed nil)
+(define-full-call call-named t :fixed nil)
+(define-full-call multiple-call nil :unknown nil)
+(define-full-call multiple-call-named t :unknown nil)
+(define-full-call tail-call nil :tail nil)
+(define-full-call tail-call-named t :tail nil)
+
+(define-full-call call-variable nil :fixed t)
+(define-full-call multiple-call-variable nil :unknown t)
+
+
+;;; Defined separately, since needs special code that BLT's the arguments
+;;; down.
+;;;
+(define-vop (tail-call-variable)
+  (:args (args-arg :scs (any-reg) :target args)
+	 (function-arg :scs (descriptor-reg) :target lexenv)
+	 (old-fp-arg :scs (any-reg) :target old-fp)
+	 (lra-arg :scs (descriptor-reg) :target lra))
+
+  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args)
+  (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
+  (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp)
+  (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra)
+  (:temporary (:scs (any-reg) :from (:argument 3)) tmp)
+
+  (:vop-var vop)
+
+  (:generator 75
+
+    ;; Move these into the passing locations if they are not already there.
+    (move args-arg args)
+    (move function-arg lexenv)
+    (move old-fp-arg old-fp)
+    (move lra-arg lra)
+
+    ;; Clear the number stack if anything is there.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst move cur-nfp nsp-tn)))
+
+    ;; And jump to the assembly-routine that does the bliting.
+    (let ((fixup (make-fixup 'tail-call-variable :assembly-routine)))
+      (inst ldil fixup tmp)
+      (inst be fixup lisp-heap-space tmp :nullify t))))
+
+
+;;;; Unknown values return:
+
+;;; Return a single value using the unknown-values convention.
+;;; 
+(define-vop (return-single)
+  (:args (old-fp :scs (any-reg))
+	 (return-pc :scs (descriptor-reg))
+	 (value))
+  (:ignore value)
+  (:vop-var vop)
+  (:generator 6
+    ;; Clear the number stack.
+    (trace-table-entry trace-table-function-epilogue)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst move cur-nfp nsp-tn)))
+    ;; Clear the control stack, and restore the frame pointer.
+    (move cfp-tn csp-tn)
+    (move old-fp cfp-tn)
+    ;; Out of here.
+    (lisp-return return-pc :offset 1)
+    (trace-table-entry trace-table-normal)))
+
+;;; Do unknown-values return of a fixed number of values.  The Values are
+;;; required to be set up in the standard passing locations.  Nvals is the
+;;; number of values returned.
+;;;
+;;; If returning a single value, then deallocate the current frame, restore
+;;; FP and jump to the single-value entry at Return-PC + 8.
+;;;
+;;; If returning other than one value, then load the number of values returned,
+;;; NIL out unsupplied values registers, restore FP and return at Return-PC.
+;;; When there are stack values, we must initialize the argument pointer to
+;;; point to the beginning of the values block (which is the beginning of the
+;;; current frame.)
+;;;
+(define-vop (return)
+  (:args
+   (old-fp :scs (any-reg))
+   (return-pc :scs (descriptor-reg) :to (:eval 1))
+   (values :more t))
+  (:ignore values)
+  (:info nvals)
+  (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0)
+  (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1)
+  (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2)
+  (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3)
+  (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4)
+  (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5)
+  (:temporary (:sc any-reg :offset nargs-offset) nargs)
+  (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
+  (:vop-var vop)
+  (:generator 6
+    ;; Clear the number stack.
+    (trace-table-entry trace-table-function-epilogue)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst move cur-nfp nsp-tn)))
+    ;; Establish the values pointer and values count.
+    (move cfp-tn val-ptr)
+    (inst li (fixnum nvals) nargs)
+    ;; restore the frame pointer and clear as much of the control
+    ;; stack as possible.
+    (move old-fp cfp-tn)
+    (inst addi (* nvals word-bytes) val-ptr csp-tn)
+    ;; pre-default any argument register that need it.
+    (when (< nvals register-arg-count)
+      (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
+	(move null-tn reg)))
+    ;; And away we go.
+    (lisp-return return-pc)
+    (trace-table-entry trace-table-normal)))
+
+;;; Do unknown-values return of an arbitrary number of values (passed on the
+;;; stack.)  We check for the common case of a single return value, and do that
+;;; inline using the normal single value return convention.  Otherwise, we
+;;; branch off to code that calls an assembly-routine.
+;;;
+(define-vop (return-multiple)
+  (:args
+   (old-fp-arg :scs (any-reg) :to (:eval 1))
+   (lra-arg :scs (descriptor-reg) :to (:eval 1))
+   (vals-arg :scs (any-reg) :target vals)
+   (nvals-arg :scs (any-reg) :target nvals))
+
+  (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp)
+  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
+  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals)
+  (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
+  (:temporary (:sc descriptor-reg :offset a0-offset) a0)
+  (:temporary (:scs (any-reg) :from (:eval 0)) tmp)
+
+  (:vop-var vop)
+  (:node-var node)
+
+  (:generator 13
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Clear the number stack.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst move cur-nfp nsp-tn)))
+
+    (unless (policy node (> space speed))
+      ;; Check for the single case.
+      (inst comib :<> (fixnum 1) nvals-arg not-single)
+      (loadw a0 vals-arg)
+
+      ;; Return with one value.
+      (move cfp-tn csp-tn)
+      (move old-fp-arg cfp-tn)
+      (lisp-return lra-arg :offset 1))
+		
+    ;; Nope, not the single case.
+    NOT-SINGLE
+    (move old-fp-arg old-fp)
+    (move lra-arg lra)
+    (move vals-arg vals)
+    (move nvals-arg nvals)
+    (let ((fixup (make-fixup 'return-multiple :assembly-routine)))
+      (inst ldil fixup tmp)
+      (inst be fixup lisp-heap-space tmp :nullify t))
+    (trace-table-entry trace-table-normal)))
+
+
+
+;;;; XEP hackery:
+
+;;; We don't need to do anything special for regular functions.
+;;;
+(define-vop (setup-environment)
+  (:info label)
+  (:ignore label)
+  (:generator 0
+    ;; Don't bother doing anything.
+    ))
+
+;;; Get the lexical environment from it's passing location.
+;;;
+(define-vop (setup-closure-environment)
+  (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
+	       :to (:result 0))
+	      lexenv)
+  (:results (closure :scs (descriptor-reg)))
+  (:info label)
+  (:ignore label)
+  (:generator 6
+    ;; Get result.
+    (move lexenv closure)))
+
+;;; Copy a more arg from the argument area to the end of the current frame.
+;;; Fixed is the number of non-more arguments. 
+;;;
+(define-vop (copy-more-arg)
+  (:temporary (:sc any-reg :offset nl0-offset) result)
+  (:temporary (:sc any-reg :offset nl1-offset) count)
+  (:temporary (:sc any-reg :offset nl2-offset) src)
+  (:temporary (:sc any-reg :offset nl3-offset) dst)
+  (:temporary (:sc descriptor-reg :offset l0-offset) temp)
+  (:info fixed)
+  (:generator 20
+    ;; Figure out how many things we are going to copy.
+    (unless (zerop fixed)
+      (inst addi (- (fixnum fixed)) nargs-tn count))
+
+    ;; Blow out of here if is nothing to copy.
+    (inst comb :<= (if (zerop fixed) nargs-tn count) zero-tn done :nullify t)
+
+    (when (< fixed register-arg-count)
+      ;; Save a pointer to the results so we can fill in register args.
+      ;; We don't need this if there are more fixed args than reg args.
+      (move csp-tn result))
+
+    ;; Allocate the space on the stack.
+    (inst add csp-tn (if (zerop fixed) nargs-tn count) csp-tn)
+
+    (when (< fixed register-arg-count)
+      ;; We must stop when we run out of stack args, not when we run out of
+      ;; args in general.
+      (inst addi (fixnum (- register-arg-count)) nargs-tn count)
+      ;; Everything of interest in registers.
+      (inst comb :<= count zero-tn do-regs))
+    ;; Initialize dst to be end of stack.
+    (move csp-tn dst)
+
+    ;; Initialize src to be end of args.
+    (inst add cfp-tn nargs-tn src)
+
+    LOOP
+    ;; *--dst = *--src, --count
+    (inst ldwm (- word-bytes) src temp)
+    (inst addib :> (fixnum -1) count loop)
+    (inst stwm temp (- word-bytes) dst)
+
+    DO-REGS
+    (when (< fixed register-arg-count)
+      ;; Now we have to deposit any more args that showed up in registers.
+      ;; We know there is at least one more arg, otherwise we would have
+      ;; branched to done up at the top.
+      (inst addi (fixnum (- fixed)) nargs-tn count)
+      (do ((i fixed (1+ i)))
+	  ((>= i register-arg-count))
+	;; Is this the last one?
+	(inst addib :<= (fixnum -1) count done)
+	;; Store it relative to the pointer saved at the start.
+	(storew (nth i register-arg-tns) result (- i fixed))))
+    DONE))
+
+;;; More args are stored consequtively on the stack, starting immediately at
+;;; the context pointer.  The context pointer is not typed, so the lowtag is 0.
+;;;
+(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)
+
+
+;;; Turn more arg (context, count) into a list.
+;;;
+(define-vop (listify-rest-args)
+  (:args (context-arg :target context :scs (descriptor-reg))
+	 (count-arg :target count :scs (any-reg)))
+  (:arg-types * tagged-num)
+  (:temporary (:scs (any-reg) :from (:argument 0)) context)
+  (:temporary (:scs (any-reg) :from (:argument 1)) count)
+  (:temporary (:scs (descriptor-reg) :from :eval) temp)
+  (:temporary (:scs (non-descriptor-reg) :from :eval) dst)
+  (:results (result :scs (descriptor-reg)))
+  (:translate %listify-rest-args)
+  (:policy :safe)
+  (:generator 20
+    (let ((loop (gen-label))
+	  (done (gen-label)))
+      (move context-arg context)
+      (move count-arg count)
+      ;; Check to see if there are any arguments.
+      (inst comb := count zero-tn done)
+      (move null-tn result)
+
+      ;; We need to do this atomically.
+      (pseudo-atomic ()
+	;; Allocate a cons (2 words) for each item.
+	(inst move alloc-tn result)
+	(inst dep list-pointer-type 31 3 result)
+	(move result dst)
+	(inst sll count 1 temp)
+	(inst add alloc-tn temp alloc-tn)
+
+	(emit-label loop)
+	;; Grab one value and stash it in the car of this cons.
+	(inst ldwm word-bytes context temp)
+	(storew temp dst 0 vm:list-pointer-type)
+
+	;; Dec count, and if != zero, go back for more.
+	(inst addi (* 2 vm:word-bytes) dst dst)
+	(inst addib :> (fixnum -1) count loop :nullify t)
+	(storew dst dst -1 list-pointer-type)
+
+	;; NIL out the last cons.
+	(storew null-tn dst -1 list-pointer-type))
+      (emit-label done))))
+
+;;; Return the location and size of the more arg glob created by Copy-More-Arg.
+;;; Supplied is the total number of arguments supplied (originally passed in
+;;; NARGS.)  Fixed is the number of non-rest arguments.
+;;;
+;;; We must duplicate some of the work done by Copy-More-Arg, since at that
+;;; time the environment is in a pretty brain-damaged state, preventing this
+;;; info from being returned as values.  What we do is compute
+;;; supplied - fixed, and return a pointer that many words below the current
+;;; stack top.
+;;;
+(define-vop (more-arg-context)
+  (:args (supplied :scs (any-reg)))
+  (:arg-types positive-fixnum)
+  (:info fixed)
+  (:results (context :scs (descriptor-reg))
+	    (count :scs (any-reg)))
+  (:generator 5
+    (inst addi (fixnum (- fixed)) supplied count)
+    (inst sub csp-tn count context)))
+
+
+;;; Signal wrong argument count error if Nargs isn't = to Count.
+;;;
+(define-vop (verify-argument-count)
+  (:args (nargs :scs (any-reg)))
+  (:arg-types positive-fixnum)
+  (:info count)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (let ((err-lab
+	   (generate-error-code vop invalid-argument-count-error nargs)))
+      (cond ((zerop count)
+	     (inst bc :<> nil nargs zero-tn err-lab))
+	    (t
+	     (inst bci :<> nil (fixnum count) nargs err-lab))))))
+
+;;; Signal an argument count error.
+;;;
+(macrolet ((frob (name error &rest args)
+	     `(define-vop (,name)
+		(:args ,@(mapcar #'(lambda (arg)
+				     `(,arg :scs (any-reg descriptor-reg)))
+				 args))
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 1000
+		  (error-call vop ,error ,@args)))))
+  (frob argument-count-error invalid-argument-count-error nargs)
+  (frob type-check-error object-not-type-error object type)
+  (frob odd-keyword-arguments-error odd-keyword-arguments-error)
+  (frob unknown-keyword-argument-error unknown-keyword-argument-error key)
+  (frob nil-function-returned-error nil-function-returned-error fun))
diff --git a/compiler/hppa/cell.lisp b/compiler/hppa/cell.lisp
new file mode 100644
index 000000000..b4ba42967
--- /dev/null
+++ b/compiler/hppa/cell.lisp
@@ -0,0 +1,273 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/cell.lisp,v 1.1 1992/07/13 03:48:20 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of various primitive memory access
+;;; VOPs for the HPPA
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "HPPA")
+
+
+;;;; Data object definition macros.
+
+(define-for-each-primitive-object (obj)
+  (collect ((forms))
+    (let ((lowtag (primitive-object-lowtag obj)))
+      (dolist (slot (primitive-object-slots obj))
+	(let* ((name (slot-name slot))
+	       (offset (slot-offset slot))
+	       (rest-p (slot-rest-p slot))
+	       (slot-opts (slot-options slot))
+	       (ref-trans (getf slot-opts :ref-trans))
+	       (ref-vop (getf slot-opts :ref-vop ref-trans))
+	       (set-trans (getf slot-opts :set-trans))
+	       (setf-function-p (and (listp set-trans)
+				     (= (length set-trans) 2)
+				     (eq (car set-trans) 'setf)))
+	       (setf-vop (getf slot-opts :setf-vop
+			       (when setf-function-p
+				 (intern (concatenate
+					  'simple-string
+					  "SET-"
+					  (string (cadr set-trans)))))))
+	       (set-vop (getf slot-opts :set-vop
+			      (if setf-vop nil set-trans))))
+	  (when ref-vop
+	    (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
+				(:variant ,offset ,lowtag)
+		      ,@(when ref-trans
+			  `((:translate ,ref-trans))))))
+	  (when (or set-vop setf-vop)
+	    (forms `(define-vop ,(cond ((and rest-p setf-vop)
+					(error "Can't automatically generate ~
+					a setf VOP for :rest-p ~
+					slots: ~S in ~S"
+					       name
+					       (primitive-object-name obj)))
+				       (rest-p `(,set-vop slot-set))
+				       ((and set-vop setf-function-p)
+					(error "Setf functions (list ~S) must ~
+					use :setf-vops."
+					       set-trans))
+				       (set-vop `(,set-vop cell-set))
+				       (setf-function-p
+					`(,setf-vop cell-setf-function))
+				       (t
+					`(,setf-vop cell-setf)))
+		      (:variant ,offset ,lowtag)
+		      ,@(when set-trans
+			  `((:translate ,set-trans)))))))))
+    (when (forms)
+      `(progn
+	 ,@(forms)))))
+
+
+
+;;;; Symbol hacking VOPs:
+
+;;; Do a cell ref with an error check for being unbound.
+;;;
+(define-vop (checked-cell-ref)
+  (:args (object :scs (descriptor-reg) :target obj-temp))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
+  (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
+
+;;; With Symbol-Value, we check that the value isn't the trap object.  So
+;;; Symbol-Value of NIL is NIL.
+;;;
+(define-vop (symbol-value checked-cell-ref)
+  (:translate symbol-value)
+  (:generator 9
+    (move object obj-temp)
+    (loadw value obj-temp symbol-value-slot other-pointer-type)
+    (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
+      (inst li unbound-marker-type temp)
+      (inst bc := nil value temp err-lab))))
+
+;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
+(define-vop (boundp-frob)
+  (:args (object :scs (descriptor-reg)))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:temporary (:scs (descriptor-reg)) value)
+  (:temporary (:type random  :scs (non-descriptor-reg)) temp))
+
+(define-vop (boundp boundp-frob)
+  (:translate boundp)
+  (:generator 9
+    (loadw value object symbol-value-slot other-pointer-type)
+    (inst li unbound-marker-type temp)
+    (inst bc :<> not-p value temp target)))
+
+(define-vop (fast-symbol-value cell-ref)
+  (:variant symbol-value-slot other-pointer-type)
+  (:policy :fast)
+  (:translate symbol-value))
+
+
+
+;;;; Fdefinition (fdefn) objects.
+
+(define-vop (safe-fdefn-function)
+  (:args (object :scs (descriptor-reg) :target obj-temp))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
+  (:generator 10
+    (move obj-temp object)
+    (loadw value obj-temp fdefn-function-slot other-pointer-type)
+    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
+      (inst bc := nil value null-tn err-lab))))
+
+(define-vop (set-fdefn-function)
+  (:policy :fast-safe)
+  (:translate (setf fdefn-function))
+  (:args (function :scs (descriptor-reg) :target result)
+	 (fdefn :scs (descriptor-reg)))
+  (:temporary (:scs (interior-reg)) lip)
+  (:temporary (:scs (non-descriptor-reg)) type)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (load-type type function (- function-pointer-type))
+    (inst addi (- function-header-type) type type)
+    (inst comb := type zero-tn normal-fn)
+    (inst addi (- (ash function-header-code-offset word-shift)
+		  function-pointer-type)
+	  function lip)
+    (inst li (make-fixup "closure_tramp" :foreign) lip)
+    NORMAL-FN
+    (storew function fdefn fdefn-function-slot other-pointer-type)
+    (storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move function result)))
+
+(define-vop (fdefn-makunbound)
+  (:policy :fast-safe)
+  (:translate fdefn-makunbound)
+  (:args (fdefn :scs (descriptor-reg) :target result))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (storew null-tn fdefn fdefn-function-slot other-pointer-type)
+    (inst li (make-fixup "undefined_tramp" :foreign) temp)
+    (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move fdefn result)))
+
+
+
+;;;; Binding and Unbinding.
+
+;;; BIND -- Establish VAL as a binding for SYMBOL.  Save the old value and
+;;; the symbol on the binding stack and stuff the new value into the
+;;; symbol.
+
+(define-vop (bind)
+  (:args (val :scs (any-reg descriptor-reg))
+	 (symbol :scs (descriptor-reg)))
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:generator 5
+    (loadw temp symbol symbol-value-slot other-pointer-type)
+    (inst addi (* binding-size word-bytes) bsp-tn bsp-tn)
+    (storew temp bsp-tn (- binding-value-slot binding-size))
+    (storew symbol bsp-tn (- binding-symbol-slot binding-size))
+    (storew val symbol symbol-value-slot other-pointer-type)))
+
+(define-vop (unbind)
+  (:temporary (:scs (descriptor-reg)) symbol value)
+  (:generator 0
+    (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+    (loadw value bsp-tn (- binding-value-slot binding-size))
+    (storew value symbol symbol-value-slot other-pointer-type)
+    (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+    (inst addi (- (* binding-size word-bytes)) bsp-tn bsp-tn)))
+
+(define-vop (unbind-to-here)
+  (:args (where :scs (descriptor-reg any-reg)))
+  (:temporary (:scs (descriptor-reg)) symbol value)
+  (:generator 0
+    (inst comb := where bsp-tn done :nullify t)
+    (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+
+    LOOP
+    (inst comb := symbol zero-tn skip)
+    (loadw value bsp-tn (- binding-value-slot binding-size))
+    (storew value symbol symbol-value-slot other-pointer-type)
+    (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+
+    SKIP
+    (inst addi (* -2 word-bytes) bsp-tn bsp-tn)
+    (inst comb :<> where bsp-tn loop :nullify t)
+    (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+
+    DONE))
+
+
+
+;;;; Closure indexing.
+
+(define-full-reffer closure-index-ref *
+  closure-info-offset function-pointer-type
+  (descriptor-reg any-reg) * %closure-index-ref)
+
+(define-full-reffer set-funcallable-instance-info *
+  funcallable-instance-info-offset function-pointer-type
+  (descriptor-reg any-reg) * %set-funcallable-instance-info)
+
+
+
+;;;; Structure hackery:
+
+(define-vop (structure-length)
+  (:policy :fast-safe)
+  (:translate structure-length)
+  (:args (struct :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (loadw res struct 0 structure-pointer-type)
+    (inst srl res type-bits res)))
+
+(define-vop (structure-ref slot-ref)
+  (:variant structure-slots-offset structure-pointer-type)
+  (:policy :fast-safe)
+  (:translate structure-ref)
+  (:arg-types structure (:constant index)))
+
+(define-vop (structure-set slot-set)
+  (:policy :fast-safe)
+  (:translate structure-set)
+  (:variant structure-slots-offset structure-pointer-type)
+  (:arg-types structure (:constant index) *))
+
+(define-full-reffer structure-index-ref * structure-slots-offset
+  structure-pointer-type (descriptor-reg any-reg) * structure-ref)
+
+(define-full-setter structure-index-set * structure-slots-offset
+  structure-pointer-type (descriptor-reg any-reg) * structure-set)
+
+
+
+;;;; Code object frobbing.
+
+(define-full-reffer code-header-ref * 0 other-pointer-type
+  (descriptor-reg any-reg) * code-header-ref)
+
+(define-full-setter code-header-set * 0 other-pointer-type
+  (descriptor-reg any-reg) * code-header-set)
diff --git a/compiler/hppa/char.lisp b/compiler/hppa/char.lisp
new file mode 100644
index 000000000..537b4d6d2
--- /dev/null
+++ b/compiler/hppa/char.lisp
@@ -0,0 +1,137 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/char.lisp,v 1.1 1992/07/13 03:48:20 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;; 
+;;; This file contains the HPPA VM definition of character operations.
+;;;
+;;; Written by William Lott
+;;;
+(in-package "HPPA")
+
+
+;;;; Moves and coercions:
+
+;;; Move a tagged char to an untagged representation.
+;;;
+(define-vop (move-to-base-char)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:results (y :scs (base-char-reg)))
+  (:generator 1
+    (inst srl x type-bits y)))
+;;;
+(define-move-vop move-to-base-char :move
+  (any-reg descriptor-reg) (base-char-reg))
+
+;;; Move an untagged char to a tagged representation.
+;;;
+(define-vop (move-from-base-char)
+  (:args (x :scs (base-char-reg)))
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (inst sll x type-bits y)
+    (inst addi base-char-type y y)))
+;;;
+(define-move-vop move-from-base-char :move
+  (base-char-reg) (any-reg descriptor-reg))
+
+;;; Move untagged base-char values.
+;;;
+(define-vop (base-char-move)
+  (:args (x :target y
+	    :scs (base-char-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (base-char-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move x y)))
+;;;
+(define-move-vop base-char-move :move
+  (base-char-reg) (base-char-reg))
+
+
+;;; Move untagged base-char arguments/return-values.
+;;;
+(define-vop (move-base-char-argument)
+  (:args (x :target y
+	    :scs (base-char-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y base-char-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      (base-char-reg
+       (move x y))
+      (base-char-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-base-char-argument :move-argument
+  (any-reg base-char-reg) (base-char-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
+;;; to a descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (base-char-reg) (any-reg descriptor-reg))
+
+
+
+;;;; Other operations:
+
+(define-vop (char-code)
+  (:translate char-code)
+  (:policy :fast-safe)
+  (:args (ch :scs (base-char-reg) :target res))
+  (:arg-types base-char)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+    (move ch res)))
+
+(define-vop (code-char)
+  (:translate code-char)
+  (:policy :fast-safe)
+  (:args (code :scs (unsigned-reg) :target res))
+  (:arg-types positive-fixnum)
+  (:results (res :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 1
+    (move code res)))
+
+
+;;; Comparison of base-chars.
+;;;
+(define-vop (base-char-compare)
+  (:args (x :scs (base-char-reg))
+	 (y :scs (base-char-reg)))
+  (:arg-types base-char base-char)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:note "inline comparison")
+  (:variant-vars cond)
+  (:generator 3
+    (inst bc cond not-p x y target)))
+
+(define-vop (fast-char=/base-char base-char-compare)
+  (:translate char=)
+  (:variant :=))
+
+(define-vop (fast-char</base-char base-char-compare)
+  (:translate char<)
+  (:variant :<<))
+
+(define-vop (fast-char>/base-char base-char-compare)
+  (:translate char>)
+  (:variant :>>))
diff --git a/compiler/hppa/debug.lisp b/compiler/hppa/debug.lisp
new file mode 100644
index 000000000..22eaaa9eb
--- /dev/null
+++ b/compiler/hppa/debug.lisp
@@ -0,0 +1,138 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/debug.lisp,v 1.1 1992/07/13 03:48:21 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Compiler support for the new whizzy debugger.
+;;;
+;;; Written by William Lott.
+;;; 
+(in-package "HPPA")
+
+
+(define-vop (debug-cur-sp)
+  (:translate current-sp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move csp-tn res)))
+
+(define-vop (debug-cur-fp)
+  (:translate current-fp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move cfp-tn res)))
+
+(define-vop (read-control-stack)
+  (:translate stack-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (sap-reg))
+	 (offset :scs (any-reg)))
+  (:arg-types system-area-pointer positive-fixnum)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 5
+    (inst ldwx offset object result)))
+
+(define-vop (read-control-stack-c)
+  (:translate stack-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (sap-reg)))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 12)))
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 4
+    (inst ldw (* offset word-bytes) object result)))
+
+(define-vop (write-control-stack)
+  (:translate %set-stack-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (sap-reg) :target sap)
+	 (offset :scs (any-reg))
+	 (value :scs (descriptor-reg) :target result))
+  (:arg-types system-area-pointer positive-fixnum *)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
+  (:generator 2
+    (inst add object offset sap)
+    (inst stw value 0 sap)
+    (move value result)))
+
+(define-vop (write-control-stack-c)
+  (:translate %set-stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (value :scs (descriptor-reg) :target result))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 12)) *)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 1
+    (inst stw value (* offset word-bytes) sap)
+    (move value result)))
+
+(define-vop (code-from-mumble)
+  (:policy :fast-safe)
+  (:args (thing :scs (descriptor-reg) :to :save))
+  (:results (code :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:variant-vars lowtag)
+  (:generator 5
+    (loadw temp thing 0 lowtag)
+    (inst srl temp type-bits temp)
+    (inst comb := zero-tn temp done)
+    (move null-tn code)
+    (inst sll temp (1- (integer-length word-bytes)) temp)
+    (unless (= lowtag other-pointer-type)
+      (inst addi (- lowtag vm:other-pointer-type) temp temp))
+    (inst sub thing temp code)
+    DONE))
+
+(define-vop (code-from-lra code-from-mumble)
+  (:translate lra-code-header)
+  (:variant other-pointer-type))
+
+(define-vop (code-from-function code-from-mumble)
+  (:translate function-code-header)
+  (:variant function-pointer-type))
+
+(define-vop (make-lisp-obj)
+  (:policy :fast-safe)
+  (:translate make-lisp-obj)
+  (:args (value :scs (unsigned-reg) :target result))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 1
+    (move value result)))
+
+(define-vop (get-lisp-obj-address)
+  (:policy :fast-safe)
+  (:translate get-lisp-obj-address)
+  (:args (thing :scs (descriptor-reg) :target result))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move thing result)))
+
+(define-vop (function-word-offset)
+  (:policy :fast-safe)
+  (:translate function-word-offset)
+  (:args (fun :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (loadw res fun 0 function-pointer-type)
+    (inst srl res type-bits res)))
diff --git a/compiler/hppa/float.lisp b/compiler/hppa/float.lisp
new file mode 100644
index 000000000..a7cb24163
--- /dev/null
+++ b/compiler/hppa/float.lisp
@@ -0,0 +1,588 @@
+;;; -*- Package: hppa -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/float.lisp,v 1.1 1992/07/13 03:48:23 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the floating point support for the HP-PA.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "HPPA")
+
+
+;;;; Move functions.
+
+(define-move-function (load-fp-zero 1) (vop x y)
+  ((fp-single-zero) (single-reg)
+   (fp-double-zero) (double-reg))
+  (inst funop :copy x y))
+
+
+(define-move-function (load-float 1) (vop x y)
+  ((single-stack) (single-reg)
+   (double-stack) (double-reg))
+  (let ((offset (* (tn-offset x) word-bytes)))
+    (cond ((< offset (ash 1 4))
+	   (inst flds offset (current-nfp-tn vop) y))
+	  (t
+	   (inst ldo offset zero-tn lip-tn)
+	   (inst fldx lip-tn (current-nfp-tn vop) y)))))
+
+(define-move-function (store-float 1) (vop x y)
+  ((single-reg) (single-stack)
+   (double-reg) (double-stack))
+  (let ((offset (* (tn-offset y) word-bytes)))
+    (cond ((< offset (ash 1 4))
+	   (inst fsts x offset (current-nfp-tn vop)))
+	  (t
+	   (inst ldo offset zero-tn lip-tn)
+	   (inst fstx x lip-tn (current-nfp-tn vop))))))
+
+
+
+;;;; Move VOPs
+
+(define-vop (move-float)
+  (:args (x :scs (single-reg double-reg)
+	    :target y
+	    :load-if (not (location= x y))))
+  (:results (y :scs (single-reg double-reg)
+	       :load-if (not (location= x y))))
+  (:note "float move")
+  (:generator 0
+    (unless (location= y x)
+      (inst funop :copy x y))))
+
+(define-move-vop move-float :move (single-reg) (single-reg))
+(define-move-vop move-float :move (double-reg) (double-reg))
+
+
+(define-vop (move-from-float)
+  (:args (x :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:variant-vars size type data)
+  (:note "float to pointer coercion")
+  (:generator 13
+    (with-fixed-allocation (y ndescr type size)
+      (inst fsts x (- (* data word-bytes) other-pointer-type) y))))
+
+(macrolet ((frob (name sc &rest args)
+	     `(progn
+		(define-vop (,name move-from-float)
+		  (:args (x :scs (,sc) :to :save))
+		  (:variant ,@args))
+		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
+  (frob move-from-single single-reg
+    single-float-size single-float-type single-float-value-slot)
+  (frob move-from-double double-reg
+    double-float-size double-float-type double-float-value-slot))
+
+(define-vop (move-from-float)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y))
+  (:variant-vars offset)
+  (:note "pointer to float coercion")
+  (:generator 2
+    (inst flds (- (* offset word-bytes) other-pointer-type) x y)))
+
+(macrolet ((frob (name sc offset)
+	     `(progn
+		(define-vop (,name move-from-float)
+		  (:results (y :scs (,sc)))
+		  (:variant ,offset))
+		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
+  (frob move-to-single single-reg single-float-value-slot)
+  (frob move-to-double double-reg double-float-value-slot))
+
+
+(define-vop (move-float-argument)
+  (:args (x :scs (single-reg double-reg) :target y)
+	 (nfp :scs (any-reg)
+	      :load-if (not (sc-is y single-reg double-reg))))
+  (:results (y))
+  (:note "float argument move")
+  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+  (:generator 1
+    (sc-case y
+      ((single-reg double-reg)
+       (unless (location= x y)
+	 (inst funop :copy x y)))
+      ((single-stack double-stack)
+       (let ((offset (* (tn-offset y) word-bytes)))
+	 (cond ((< offset (ash 1 4))
+		(inst fsts x offset nfp))
+	       (t
+		(inst ldo offset zero-tn index)
+		(inst fstx x index nfp))))))))
+
+(define-move-vop move-float-argument :move-argument
+  (single-reg descriptor-reg) (single-reg))
+(define-move-vop move-float-argument :move-argument
+  (double-reg descriptor-reg) (double-reg))
+
+
+(define-move-vop move-argument :move-argument
+  (single-reg double-reg) (descriptor-reg))
+
+
+
+;;;; Arithmetic VOPs.
+
+(define-vop (float-op)
+  (:args (x) (y))
+  (:results (r))
+  (:variant-vars operation)
+  (:policy :fast-safe)
+  (:note "inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 0
+    (note-this-location vop :internal-error)
+    (inst fbinop operation x y r)))
+
+(macrolet ((frob (name sc zero-sc ptype)
+	     `(define-vop (,name float-op)
+		(:args (x :scs (,sc ,zero-sc))
+		       (y :scs (,sc ,zero-sc)))
+		(:results (r :scs (,sc)))
+		(:arg-types ,ptype ,ptype)
+		(:result-types ,ptype))))
+  (frob single-float-op single-reg fp-single-zero single-float)
+  (frob double-float-op double-reg fp-double-zero double-float))
+
+(macrolet ((frob (translate op sname scost dname dcost)
+	     `(progn
+		(define-vop (,sname single-float-op)
+		  (:translate ,translate)
+		  (:variant ,op)
+		  (:variant-cost ,scost))
+		(define-vop (,dname double-float-op)
+		  (:translate ,translate)
+		  (:variant ,op)
+		  (:variant-cost ,dcost)))))
+  (frob + :add +/single-float 2 +/double-float 2)
+  (frob - :sub -/single-float 2 -/double-float 2)
+  (frob * :mpy */single-float 4 */double-float 5)
+  (frob / :div //single-float 12 //double-float 19))
+
+
+(macrolet ((frob (name translate sc type inst)
+	     `(define-vop (,name)
+		(:args (x :scs (,sc)))
+		(:results (y :scs (,sc)))
+		(:translate ,translate)
+		(:policy :fast-safe)
+		(:arg-types ,type)
+		(:result-types ,type)
+		(:note "inline float arithmetic")
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 1
+		  (note-this-location vop :internal-error)
+		  ,inst))))
+  (frob abs/single-float abs single-reg single-float
+    (inst funop :abs x y))
+  (frob abs/double-float abs double-reg double-float
+    (inst funop :abs x y))
+  (frob %negate/single-float %negate single-reg single-float
+    (inst fbinop :sub fp-single-zero-tn x y))
+  (frob %negate/double-float %negate double-reg double-float
+    (inst fbinop :sub fp-double-zero-tn x y)))
+
+
+;;;; Comparison:
+
+(define-vop (float-compare)
+  (:args (x) (y))
+  (:conditional)
+  (:info target not-p)
+  (:variant-vars condition complement)
+  (:policy :fast-safe)
+  (:note "inline float comparison")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (note-this-location vop :internal-error)
+    ;; This is the condition to nullify the branch, so it is inverted.
+    (inst fcmp (if not-p condition complement) x y)
+    (inst ftest)
+    (inst b target :nullify t)))
+
+(macrolet ((frob (name sc zero-sc ptype)
+	     `(define-vop (,name float-compare)
+		(:args (x :scs (,sc ,zero-sc))
+		       (y :scs (,sc ,zero-sc)))
+		(:arg-types ,ptype ,ptype))))
+  (frob single-float-compare single-reg fp-single-zero single-float)
+  (frob double-float-compare double-reg fp-double-zero double-float))
+
+(macrolet ((frob (translate condition complement sname dname)
+	     `(progn
+		(define-vop (,sname single-float-compare)
+		  (:translate ,translate)
+		  (:variant ,condition ,complement))
+		(define-vop (,dname double-float-compare)
+		  (:translate ,translate)
+		  (:variant ,condition ,complement)))))
+  (frob < #b01001 #b10101 </single-float </double-float)
+  (frob > #b10001 #b01101 >/single-float >/double-float)
+  (frob eql #b00101 #b11001 eql/single-float eql/double-float))
+
+
+;;;; Conversion:
+
+(macrolet ((frob (name translate from-sc from-type to-sc to-type)
+	     `(define-vop (,name)
+		(:args (x :scs (,from-sc)))
+		(:results (y :scs (,to-sc)))
+		(:arg-types ,from-type)
+		(:result-types ,to-type)
+		(:policy :fast-safe)
+		(:note "inline float coercion")
+		(:translate ,translate)
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 2
+		  (note-this-location vop :internal-error)
+		  (inst fcnvff x y)))))
+  (frob %single-float/double-float %single-float
+    double-reg double-float
+    single-reg single-float)
+  (frob %double-float/single-float %double-float
+    single-reg single-float
+    double-reg double-float))
+
+(macrolet ((frob (name translate to-sc to-type)
+	     `(define-vop (,name)
+		(:args (x :scs (signed-reg)
+			  :load-if (not (sc-is x signed-stack))
+			  :target stack-temp))
+		(:arg-types signed-num)
+		(:results (y :scs (,to-sc)))
+		(:result-types ,to-type)
+		(:policy :fast-safe)
+		(:note "inline float coercion")
+		(:translate ,translate)
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:temporary (:scs (signed-stack) :from (:argument 0))
+			    stack-temp)
+		(:temporary (:scs (single-reg) :to (:result 0) :target y)
+			    fp-temp)
+		(:temporary (:scs (any-reg) :from (:argument 0)
+				  :to (:result 0)) index)
+		(:generator 5
+		  (let* ((nfp (current-nfp-tn vop))
+			 (stack-tn
+			  (sc-case x
+			    (signed-stack
+			     x)
+			    (signed-reg
+			     (storew x nfp (tn-offset stack-temp))
+			     stack-temp)))
+			 (offset (* (tn-offset stack-tn) word-bytes)))
+		    (cond ((< offset (ash 1 4))
+			   (inst flds offset nfp fp-temp))
+			  (t
+			   (inst ldo offset zero-tn index)
+			   (inst fldx index nfp fp-temp)))
+		    (note-this-location vop :internal-error)
+		    (inst fcnvxf fp-temp y))))))
+  (frob %single-float/signed %single-float
+    single-reg single-float)
+  (frob %double-float/signed %double-float
+    double-reg double-float))
+
+
+(macrolet ((frob (trans from-sc from-type inst note)
+	     `(define-vop (,(symbolicate trans "/" from-type))
+		(:args (x :scs (,from-sc)
+			  :target fp-temp))
+		(:results (y :scs (signed-reg)
+			     :load-if (not (sc-is y signed-stack))))
+		(:arg-types ,from-type)
+		(:result-types signed-num)
+		(:translate ,trans)
+		(:policy :fast-safe)
+		(:note ,note)
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:temporary (:scs (single-reg) :from (:argument 0)) fp-temp)
+		(:temporary (:scs (signed-stack) :to (:result 0) :target y)
+			    stack-temp)
+		(:temporary (:scs (any-reg) :from (:argument 0)
+				  :to (:result 0)) index)
+		(:generator 3
+		  (let* ((nfp (current-nfp-tn vop))
+			 (stack-tn
+			  (sc-case y
+			    (signed-stack y)
+			    (signed-reg stack-temp)))
+			 (offset (* (tn-offset stack-tn) word-bytes)))
+		    (note-this-location vop :internal-error)
+		    (inst ,inst x fp-temp)
+		    (cond ((< offset (ash 1 4))
+			   (inst fsts fp-temp offset nfp))
+			  (t
+			   (inst ldo offset zero-tn index)
+			   (inst fstx fp-temp index nfp)))
+		    (unless (eq y stack-tn)
+		      (loadw y nfp (tn-offset stack-tn))))))))
+  (frob %unary-round single-reg single-float fcnvfx "inline float round")
+  (frob %unary-round double-reg double-float fcnvfx "inline float round")
+  (frob %unary-truncate single-reg single-float fcnvfxt
+    "inline float truncate")
+  (frob %unary-truncate double-reg double-float fcnvfxt
+    "inline float truncate"))
+
+
+(define-vop (make-single-float)
+  (:args (bits :scs (signed-reg)
+	       :load-if (or (not (sc-is bits signed-stack))
+			    (sc-is res single-stack))
+	       :target res))
+  (:results (res :scs (single-reg)
+		 :load-if (not (sc-is bits single-stack))))
+  (:arg-types signed-num)
+  (:result-types single-float)
+  (:translate make-single-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp)
+  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+  (:generator 2
+    (let ((nfp (current-nfp-tn vop)))
+      (sc-case bits
+	(signed-reg
+	 (sc-case res
+	   (single-reg
+	    (let ((offset (* (tn-offset temp) word-bytes)))
+	      (inst stw bits offset nfp)
+	      (cond ((< offset (ash 1 4))
+		     (inst flds offset nfp res))
+		    (t
+		     (inst ldo offset zero-tn index)
+		     (inst fldx index nfp res)))))
+	   (single-stack
+	    (inst stw bits (* (tn-offset res) word-bytes) nfp))))
+	(signed-stack
+	 (sc-case res
+	   (single-reg
+	    (let ((offset (* (tn-offset bits) word-bytes)))
+	      (cond ((< offset (ash 1 4))
+		     (inst flds offset nfp res))
+		    (t
+		     (inst ldo offset zero-tn index)
+		     (inst fldx index nfp res)))))))))))
+
+(define-vop (make-double-float)
+  (:args (hi-bits :scs (signed-reg))
+	 (lo-bits :scs (unsigned-reg)))
+  (:results (res :scs (double-reg)
+		 :load-if (not (sc-is res double-stack))))
+  (:arg-types signed-num unsigned-num)
+  (:result-types double-float)
+  (:translate make-double-float)
+  (:policy :fast-safe)
+  (:temporary (:scs (double-stack) :to (:result 0)) temp)
+  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+  (:vop-var vop)
+  (:generator 2
+    (let* ((nfp (current-nfp-tn vop))
+	   (stack-tn (sc-case res
+		       (double-stack res)
+		       (double-reg temp)))
+	   (offset (* (tn-offset stack-tn) word-bytes)))
+      (inst stw hi-bits offset nfp)
+      (inst stw lo-bits (+ offset word-bytes) nfp)
+      (cond ((eq stack-tn res))
+	    ((< offset (ash 1 4))
+	     (inst flds offset nfp res))
+	    (t
+	     (inst ldo offset zero-tn index)
+	     (inst fldx index nfp res))))))
+
+
+(define-vop (single-float-bits)
+  (:args (float :scs (single-reg)
+		:load-if (not (sc-is float single-stack))))
+  (:results (bits :scs (signed-reg)
+		  :load-if (or (not (sc-is bits signed-stack))
+			       (sc-is float single-stack))))
+  (:arg-types single-float)
+  (:result-types signed-num)
+  (:translate single-float-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
+  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+  (:generator 2
+    (let ((nfp (current-nfp-tn vop)))
+      (sc-case float
+	(single-reg
+	 (sc-case bits
+	   (signed-reg
+	    (let ((offset (* (tn-offset temp) word-bytes)))
+	      (cond ((< offset (ash 1 4))
+		     (inst fsts float offset nfp))
+		    (t
+		     (inst ldo offset zero-tn index)
+		     (inst fstx float index nfp)))
+	      (inst ldw offset nfp bits)))
+	   (signed-stack
+	    (let ((offset (* (tn-offset bits) word-bytes)))
+	      (cond ((< offset (ash 1 4))
+		     (inst fsts float offset nfp))
+		    (t
+		     (inst ldo offset zero-tn index)
+		     (inst fstx float index nfp)))))))
+	(single-stack
+	 (sc-case bits
+	   (signed-reg
+	    (inst ldw (* (tn-offset float) word-bytes) nfp bits))))))))
+
+(define-vop (double-float-high-bits)
+  (:args (float :scs (double-reg)
+		:load-if (not (sc-is float double-stack))))
+  (:results (hi-bits :scs (signed-reg)
+		     :load-if (or (not (sc-is hi-bits signed-stack))
+				  (sc-is float double-stack))))
+  (:arg-types double-float)
+  (:result-types signed-num)
+  (:translate double-float-high-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
+  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+  (:generator 2
+    (let ((nfp (current-nfp-tn vop)))
+      (sc-case float
+	(double-reg
+	 (sc-case hi-bits
+	   (signed-reg
+	    (let ((offset (* (tn-offset temp) word-bytes)))
+	      (cond ((< offset (ash 1 4))
+		     (inst fsts float offset nfp :side 0))
+		    (t
+		     (inst ldo offset zero-tn index)
+		     (inst fstx float index nfp :side 0)))
+	      (inst ldw offset nfp hi-bits)))
+	   (signed-stack
+	    (let ((offset (* (tn-offset hi-bits) word-bytes)))
+	      (cond ((< offset (ash 1 4))
+		     (inst fsts float offset nfp :side 0))
+		    (t
+		     (inst ldo offset zero-tn index)
+		     (inst fstx float index nfp :side 0)))))))
+	(double-stack
+	 (sc-case hi-bits
+	   (signed-reg
+	    (let ((offset (* (tn-offset float) word-bytes)))
+	      (inst ldw offset nfp hi-bits)))))))))
+
+(define-vop (double-float-low-bits)
+  (:args (float :scs (double-reg)
+		:load-if (not (sc-is float double-stack))))
+  (:results (lo-bits :scs (unsigned-reg)
+		     :load-if (or (not (sc-is lo-bits unsigned-stack))
+				  (sc-is float double-stack))))
+  (:arg-types double-float)
+  (:result-types unsigned-num)
+  (:translate double-float-low-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
+  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+  (:generator 2
+    (let ((nfp (current-nfp-tn vop)))
+      (sc-case float
+	(double-reg
+	 (sc-case lo-bits
+	   (unsigned-reg
+	    (let ((offset (* (tn-offset temp) word-bytes)))
+	      (cond ((< offset (ash 1 4))
+		     (inst fsts float offset nfp :side 1))
+		    (t
+		     (inst ldo offset zero-tn index)
+		     (inst fstx float index nfp :side 1)))
+	      (inst ldw offset nfp lo-bits)))
+	   (unsigned-stack
+	    (let ((offset (* (tn-offset lo-bits) word-bytes)))
+	      (cond ((< offset (ash 1 4))
+		     (inst fsts float offset nfp :side 1))
+		    (t
+		     (inst ldo offset zero-tn index)
+		     (inst fstx float index nfp :side 1)))))))
+	(double-stack
+	 (sc-case lo-bits
+	   (unsigned-reg
+	    (let ((offset (* (1+ (tn-offset float)) word-bytes)))
+	      (inst ldw offset nfp lo-bits)))))))))
+
+
+
+;;;; Float mode hackery:
+
+(deftype float-modes () '(unsigned-byte 32))
+(defknown floating-point-modes () float-modes (flushable))
+(defknown ((setf floating-point-modes)) (float-modes)
+  float-modes)
+
+(define-vop (floating-point-modes)
+  (:results (res :scs (unsigned-reg)
+		 :load-if (not (sc-is res unsigned-stack))))
+  (:result-types unsigned-num)
+  (:translate floating-point-modes)
+  (:policy :fast-safe)
+  (:temporary (:scs (unsigned-stack) :to (:result 0)) temp)
+  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+  (:vop-var vop)
+  (:generator 3
+    (let* ((nfp (current-nfp-tn vop))
+	   (stack-tn (sc-case res
+		       (unsigned-stack res)
+		       (unsigned-reg temp)))
+	   (offset (* (tn-offset stack-tn) word-bytes)))
+      (cond ((< offset (ash 1 4))
+	     (inst fsts fp-single-zero-tn offset nfp))
+	    (t
+	     (inst ldo offset zero-tn index)
+	     (inst fstx fp-single-zero-tn index nfp)))
+      (unless (eq stack-tn res)
+	(inst ldw offset nfp res)))))
+
+(define-vop (set-floating-point-modes)
+  (:args (new :scs (unsigned-reg)
+	      :load-if (not (sc-is new unsigned-stack))))
+  (:results (res :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:result-types unsigned-num)
+  (:translate (setf floating-point-modes))
+  (:policy :fast-safe)
+  (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
+  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+  (:vop-var vop)
+  (:generator 3
+    (let* ((nfp (current-nfp-tn vop))
+	   (stack-tn (sc-case new
+		       (unsigned-stack new)
+		       (unsigned-reg temp)))
+	   (offset (* (tn-offset stack-tn) word-bytes)))
+      (unless (eq new stack-tn)
+	(inst stw new offset nfp))
+      (cond ((< offset (ash 1 4))
+	     (inst flds offset nfp fp-single-zero-tn))
+	    (t
+	     (inst ldo offset zero-tn index)
+	     (inst fldx index nfp fp-single-zero-tn)))
+      (inst ldw offset nfp res))))
diff --git a/compiler/hppa/insts.lisp b/compiler/hppa/insts.lisp
new file mode 100644
index 000000000..33ed010ab
--- /dev/null
+++ b/compiler/hppa/insts.lisp
@@ -0,0 +1,1056 @@
+;;; -*- Package: hppa -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/insts.lisp,v 1.1 1992/07/13 03:48:23 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the instruction set definition for the HP-PA.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package :hppa)
+
+(use-package :new-assem)
+
+(def-assembler-params
+  :scheduler-p nil)
+
+
+;;;; Utility functions.
+
+(defun reg-tn-encoding (tn)
+  (declare (type tn tn)
+	   (values (unsigned-byte 5)))
+  (sc-case tn
+    (null null-offset)
+    (zero zero-offset)
+    (t
+     (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+     (tn-offset tn))))
+
+(defun fp-reg-tn-encoding (tn)
+  (declare (type tn tn)
+	   (values (unsigned-byte 5) (member t nil)))
+  (sc-case tn
+    (fp-single-zero (values 0 nil))
+    (single-reg (values (tn-offset tn) nil))
+    (fp-double-zero (values 0 t))
+    (double-reg (values (tn-offset tn) t))))
+
+(defconstant compare-conditions
+  '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev))
+
+(deftype compare-condition ()
+  `(member nil ,@compare-conditions))
+
+(defun compare-condition (cond)
+  (declare (type compare-condition cond)
+	   (values (unsigned-byte 3) (member t nil)))
+  (if cond
+      (let ((result (or (position cond compare-conditions :test #'eq)
+			(error "Bogus Compare/Subtract condition: ~S" cond))))
+	(values (ldb (byte 3 0) result)
+		(logbitp 3 result)))
+      (values 0 nil)))
+
+(defconstant add-conditions
+  '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev))
+
+(deftype add-condition ()
+  `(member nil ,@add-conditions))
+
+(defun add-condition (cond)
+  (declare (type add-condition cond)
+	   (values (unsigned-byte 3) (member t nil)))
+  (if cond
+      (let ((result (or (position cond add-conditions :test #'eq)
+			(error "Bogus Add condition: ~S" cond))))
+	(values (ldb (byte 3 0) result)
+		(logbitp 3 result)))
+      (values 0 nil)))
+
+(defconstant logical-conditions
+  '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev))
+
+(deftype logical-condition ()
+  `(member nil ,@(remove nil logical-conditions)))
+
+(defun logical-condition (cond)
+  (declare (type logical-condition cond)
+	   (values (unsigned-byte 3) (member t nil)))
+  (if cond
+      (let ((result (or (position cond logical-conditions :test #'eq)
+			(error "Bogus Logical condition: ~S" cond))))
+	(values (ldb (byte 3 0) result)
+		(logbitp 3 result)))
+      (values 0 nil)))
+
+(defconstant unit-conditions
+  '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc))
+
+(deftype unit-condition ()
+  `(member nil ,@(remove nil unit-conditions)))
+
+(defun unit-condition (cond)
+  (declare (type unit-condition cond)
+	   (values (unsigned-byte 3) (member t nil)))
+  (if cond
+      (let ((result (or (position cond unit-conditions :test #'eq)
+			(error "Bogus Unit condition: ~S" cond))))
+	(values (ldb (byte 3 0) result)
+		(logbitp 3 result)))
+      (values 0 nil)))
+
+(defconstant extract/deposit-conditions
+  '(:never := :< :od :tr :<> :>= :ev))
+
+(deftype extract/deposit-condition ()
+  `(member nil ,@extract/deposit-conditions))
+
+(defun extract/deposit-condition (cond)
+  (declare (type extract/deposit-condition cond)
+	   (values (unsigned-byte 3) (member t nil)))
+  (if cond
+      (or (position cond extract/deposit-conditions :test #'eq)
+	  (error "Bogus Extract/Deposit condition: ~S" cond))
+      0))
+
+
+(defun space-encoding (space)
+  (declare (type (unsigned-byte 3) space)
+	   (values (unsigned-byte 3)))
+  (dpb (ldb (byte 2 0) space)
+       (byte 2 1)
+       (ldb (byte 1 2) space)))
+
+
+
+;;;; Load and Store stuff.
+
+(define-emitter emit-load/store 32
+  (byte 6 26)
+  (byte 5 21)
+  (byte 5 16)
+  (byte 2 14)
+  (byte 14 0))
+
+
+(defun im14-encoding (segment disp)
+  (declare (type (or fixup (signed-byte 14))))
+  (cond ((fixup-p disp)
+	 (note-fixup segment :load disp)
+	 (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+	 0)
+	(t
+	 (dpb (ldb (byte 13 0) disp)
+	      (byte 13 1)
+	      (ldb (byte 1 13) disp)))))
+
+(eval-when (compile eval)
+  (defmacro define-load-inst (name opcode)
+    `(define-instruction ,name (segment disp base reg)
+       (:declare (type tn reg base)
+		 (type (or fixup (signed-byte 14)) disp))
+       (:emitter
+	(emit-load/store segment ,opcode
+			 (reg-tn-encoding base) (reg-tn-encoding reg) 0
+			 (im14-encoding segment disp)))))  
+  (defmacro define-store-inst (name opcode)
+    `(define-instruction ,name (segment reg disp base)
+       (:declare (type tn reg base)
+		 (type (or fixup (signed-byte 14)) disp))
+       (:emitter
+	(emit-load/store segment ,opcode
+			 (reg-tn-encoding base) (reg-tn-encoding reg) 0
+			 (im14-encoding segment disp))))))
+
+(define-load-inst ldw #x12)
+(define-load-inst ldh #x11)
+(define-load-inst ldb #x10)
+(define-load-inst ldwm #x13)
+
+(define-store-inst stw #x1A)
+(define-store-inst sth #x19)
+(define-store-inst stb #x18)
+(define-store-inst stwm #x1B)
+
+(define-emitter emit-extended-load/store 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
+  (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
+
+(eval-when (compile eval)
+  (defmacro define-load-indexed-inst (name opcode)
+    `(define-instruction ,name (segment index base reg &key modify scale)
+       (:declare (type tn reg base index)
+		 (type (member t nil) modify scale))
+       (:emitter
+	(emit-extended-load/store
+	 segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
+	 0 (if scale 1 0) 0 ,opcode (if modify 1 0)
+	 (reg-tn-encoding reg))))))
+
+(define-load-indexed-inst ldwx 2)
+(define-load-indexed-inst ldhx 1)
+(define-load-indexed-inst ldbx 0)
+(define-load-indexed-inst ldcwx 7)
+
+(defun short-disp-encoding (segment disp)
+  (declare (type (or fixup (signed-byte 5)) disp)
+	   (values (unsigned-byte 5)))
+  (cond ((fixup-p disp)
+	 (note-fixup segment :load-short disp)
+	 (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+	 0)
+	(t
+	 (dpb (ldb (byte 4 0) disp)
+	      (byte 4 1)
+	      (ldb (byte 1 4) disp)))))
+
+(eval-when (compile eval)
+  (defmacro define-load-short-inst (name opcode)
+    `(define-instruction ,name (segment base disp reg &key modify)
+       (:declare (type tn base reg)
+		 (type (or fixup (signed-byte 5)) disp)
+		 (type (member :before :after nil) modify))
+       (:emitter
+	(multiple-value-bind
+	    (m a)
+	    (ecase modify
+	      ((nil) (values 0 0))
+	      (:after (values 1 0))
+	      (:before (values 1 1)))
+	  (emit-extended-load/store segment #x03 (reg-tn-encoding base)
+				    (short-disp-encoding segment disp)
+				    0 a 4 ,opcode m
+				    (reg-tn-encoding reg))))))
+  (defmacro define-store-short-inst (name opcode)
+    `(define-instruction ,name (segment reg base disp &key modify)
+       (:declare (type tn reg base)
+		 (type (or fixup (signed-byte 5)) disp)
+		 (type (member :before :after nil) modify))
+       (:emitter
+	(multiple-value-bind
+	    (m a)
+	    (ecase modify
+	      ((nil) (values 0 0))
+	      (:after (values 1 0))
+	      (:before (values 1 1)))
+	  (emit-extended-load/store segment #x03 (reg-tn-encoding base)
+				    (short-disp-encoding segment disp)
+				    0 a 4 ,opcode m
+				    (reg-tn-encoding reg)))))))
+
+(define-load-short-inst ldws 2)
+(define-load-short-inst ldhs 1)
+(define-load-short-inst ldbs 0)
+(define-load-short-inst ldcws 7)
+
+(define-store-short-inst stws 10)
+(define-store-short-inst sths 9)
+(define-store-short-inst stbs 8)
+
+(define-instruction stbys (segment reg base disp where &key modify)
+  (:declare (type tn reg base)
+	    (type (signed-byte 5) disp)
+	    (type (member :begin :end) where)
+	    (type (member t nil) modify))
+  (:emitter
+   (emit-extended-load/store segment #x03 (reg-tn-encoding base)
+			     (reg-tn-encoding reg) 0
+			     (ecase where (:begin 0) (:end 1))
+			     4 #xC (if modify 1 0)
+			     (short-disp-encoding segment disp))))
+
+
+;;;; Immediate Instructions.
+
+(define-load-inst ldo #x0D)
+
+(define-emitter emit-ldil 32
+  (byte 6 26)
+  (byte 5 21)
+  (byte 21 0))
+
+(defun immed-21-encoding (segment value)
+  (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value)
+	   (values (unsigned-byte 21)))
+  (cond ((fixup-p value)
+	 (note-fixup segment :hi value)
+	 (assert (or (null (fixup-offset value)) (zerop (fixup-offset value))))
+	 0)
+	(t
+	 (logior (ash (ldb (byte 5 2) value) 16)
+		 (ash (ldb (byte 2 7) value) 14)
+		 (ash (ldb (byte 2 0) value) 12)
+		 (ash (ldb (byte 11 9) value) 1)
+		 (ldb (byte 1 20) value)))))
+
+(define-instruction ldil (segment value reg)
+  (:declare (type tn reg)
+	    (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+  (:emitter
+   (emit-ldil segment #x08 (reg-tn-encoding reg)
+	      (immed-21-encoding segment value))))
+
+(define-instruction addil (segment value reg)
+  (:declare (type tn reg)
+	    (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+  (:emitter
+   (emit-ldil segment #x0A (reg-tn-encoding reg)
+	      (immed-21-encoding segment value))))
+
+
+;;;; Branch instructions.
+
+(define-emitter emit-branch 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
+  (byte 11 2) (byte 1 1) (byte 1 0))
+
+(defun label-relative-displacement (label posn &optional delta-if-after)
+  (declare (type label label) (type index posn)
+	   (values integer))
+  (ash (- (if delta-if-after
+	      (label-position label posn delta-if-after)
+	      (label-position label))
+	  (+ posn 8)) -2))
+
+(defun decompose-branch-disp (segment disp)
+  (declare (type (or fixup (signed-byte 17)) disp))
+  (cond ((fixup-p disp)
+	 (note-fixup segment :branch disp)
+	 (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+	 (values 0 0 0))
+	(t
+	 (values (ldb (byte 5 11) disp)
+		 (dpb (ldb (byte 10 0) disp)
+		      (byte 10 1)
+		      (ldb (byte 1 10) disp))
+		 (ldb (byte 1 16) disp)))))
+
+(defun emit-relative-branch (segment opcode link sub-opcode target nullify)
+  (declare (type (unsigned-byte 6) opcode)
+	   (type (unsigned-byte 5) link)
+	   (type (unsigned-byte 1) sub-opcode)
+	   (type label target)
+	   (type (member t nil) nullify))
+  (emit-back-patch segment 4
+    #'(lambda (segment posn)
+	(let ((disp (label-relative-displacement target posn)))
+	  (assert (<= (- (ash 1 16)) disp (1- (ash 1 16))))
+	  (multiple-value-bind
+	      (w1 w2 w)
+	      (decompose-branch-disp segment disp)
+	    (emit-branch segment opcode link w1 sub-opcode w2
+			 (if nullify 1 0) w))))))
+
+(define-instruction b (segment target &key nullify)
+  (:declare (type label target) (type (member t nil) nullify))
+  (:emitter
+   (emit-relative-branch segment #x3A 0 0 target nullify)))
+
+(define-instruction bl (segment target reg &key nullify)
+  (:declare (type tn reg) (type label target) (type (member t nil) nullify))
+  (:emitter
+   (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
+
+(define-instruction gateway (segment target reg &key nullify)
+  (:declare (type tn reg) (type label target) (type (member t nil) nullify))
+  (:emitter
+   (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
+
+;;; BLR is useless because we have no way to generate the offset.
+
+(define-instruction bv (segment base &key nullify offset)
+  (:declare (type tn base)
+	    (type (member t nil) nullify)
+	    (type (or tn null) offset))
+  (:emitter
+   (emit-branch segment #x3A (reg-tn-encoding base)
+		(if offset (reg-tn-encoding offset) 0)
+		6 0 (if nullify 1 0) 0)))
+
+(define-instruction be (segment disp space base &key nullify)
+  (:declare (type (or fixup (signed-byte 17)) disp)
+	    (type tn base)
+	    (type (unsigned-byte 3) space)
+	    (type (member t nil) nullify))
+  (:emitter
+   (multiple-value-bind
+       (w1 w2 w)
+       (decompose-branch-disp segment disp)
+     (emit-branch segment #x38 (reg-tn-encoding base) w1
+		  (space-encoding space) w2 (if nullify 1 0) w))))
+
+(define-instruction ble (segment disp space base &key nullify)
+  (:declare (type (or fixup (signed-byte 17)) disp)
+	    (type tn base)
+	    (type (unsigned-byte 3) space)
+	    (type (member t nil) nullify))
+  (:emitter
+   (multiple-value-bind
+       (w1 w2 w)
+       (decompose-branch-disp segment disp)
+     (emit-branch segment #x39 (reg-tn-encoding base) w1
+		  (space-encoding space) w2 (if nullify 1 0) w))))
+
+(defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
+  (emit-back-patch segment 4
+    #'(lambda (segment posn)
+	(let ((disp (label-relative-displacement target posn)))
+	  (assert (<= (- (ash 1 11)) disp (1- (ash 1 11))))
+	  (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
+			    (ldb (byte 1 10) disp)))
+		(w (ldb (byte 1 11) disp)))
+	    (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
+
+(defun im5-encoding (value)
+  (declare (type (signed-byte 5) value)
+	   (values (unsigned-byte 5)))
+  (dpb (ldb (byte 4 0) value)
+       (byte 4 1)
+       (ldb (byte 1 4) value)))
+
+(eval-when (compile eval)
+  (defmacro define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
+    (let ((conditional (symbolicate cond-kind "-CONDITION")))
+      `(progn
+	 (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
+	   (:declare (type ,conditional cond)
+		     (type tn r1 r2)
+		     (type label target)
+		     (type (member t nil) nullify))
+	   (:emitter
+	    (multiple-value-bind
+		(cond-encoding false)
+		(,conditional cond)
+	      (emit-conditional-branch
+	       segment (if false ,(+ r-opcode 2) ,r-opcode)
+	       (reg-tn-encoding r2) (reg-tn-encoding r1)
+	       cond-encoding target nullify))))
+	 (define-instruction ,i-name (segment cond imm reg target &key nullify)
+	   (:declare (type ,conditional cond)
+		     (type (signed-byte 5) imm)
+		     (type tn reg)
+		     (type (member t nil) nullify))
+	   (:emitter
+	    (multiple-value-bind
+		(cond-encoding false)
+		(,conditional cond)
+	      (emit-conditional-branch
+	       segment (if false (+ ,i-opcode 2) ,i-opcode)
+	       (reg-tn-encoding reg) (im5-encoding imm)
+	       cond-encoding target nullify))))))))
+
+(define-branch-inst movb #x32 movib #x33 extract/deposit)
+(define-branch-inst comb #x20 comib #x21 compare)
+(define-branch-inst addb #x28 addib #x29 add)
+
+(define-instruction bb (segment cond reg posn target &key nullify)
+  (:declare (type (member t nil) cond nullify)
+	    (type tn reg)
+	    (type (or (member :variable) (unsigned-byte 5)) posn))
+  (:emitter
+   (multiple-value-bind
+       (opcode posn-encoding)
+       (if (eq posn :variable)
+	   (values  0)
+	   (values #x31 posn))
+     (emit-conditional-branch segment opcode posn-encoding
+			      (reg-tn-encoding reg)
+			      (if cond 2 6) target nullify))))
+
+
+;;;; Computation Instructions
+
+(define-emitter emit-r3-inst 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
+  (byte 1 12) (byte 7 5) (byte 5 0))
+
+(eval-when (compile eval)
+  (defmacro define-r3-inst (name cond-kind opcode)
+    `(define-instruction ,name (segment r1 r2 res &optional cond)
+       (:declare (type tn res r1 r2))
+       (:emitter
+	(multiple-value-bind
+	    (cond false)
+	    (,(symbolicate cond-kind "-CONDITION") cond)
+	  (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
+			cond (if false 1 0) ,opcode
+			(reg-tn-encoding res)))))))
+  
+(define-r3-inst add add #x30)
+(define-r3-inst addl add #x50)
+(define-r3-inst addo add #x70)
+(define-r3-inst addc add #x38)
+(define-r3-inst addco add #x78)
+(define-r3-inst sh1add add #x32)
+(define-r3-inst sh1addl add #x52)
+(define-r3-inst sh1addo add #x72)
+(define-r3-inst sh2add add #x34)
+(define-r3-inst sh2addl add #x54)
+(define-r3-inst sh2addo add #x74)
+(define-r3-inst sh3add add #x36)
+(define-r3-inst sh3addl add #x56)
+(define-r3-inst sh3addo add #x76)
+(define-r3-inst sub compare #x20)
+(define-r3-inst subo compare #x60)
+(define-r3-inst subb compare #x28)
+(define-r3-inst subbo compare #x68)
+(define-r3-inst subt compare #x26)
+(define-r3-inst subto compare #x66)
+(define-r3-inst ds compare #x22)
+(define-r3-inst comclr compare #x44)
+(define-r3-inst or logical #x12)
+(define-r3-inst xor logical #x14)
+(define-r3-inst and logical #x10)
+(define-r3-inst andcm logical #x00)
+(define-r3-inst uxor unit #x1C)
+(define-r3-inst uaddcm unit #x4C)
+(define-r3-inst uaddcmt unit #x4E)
+(define-r3-inst dcor unit #x5C)
+(define-r3-inst idcor unit #x5E)
+
+(define-emitter emit-imm-inst 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
+  (byte 1 12) (byte 1 11) (byte 11 0))
+
+(defun im11-encoding (value)
+  (declare (type (signed-byte 11) value)
+	   (values (unsigned-byte 11)))
+  (dpb (ldb (byte 10 0) value)
+       (byte 10 1)
+       (ldb (byte 1 10) value)))
+
+(eval-when (compile eval)
+  (defmacro define-imm-inst (name cond-kind opcode subcode)
+    `(define-instruction ,name (segment imm src dst &optional cond)
+       (:declare (type tn dst src)
+		 (type (signed-byte 11) imm))
+       (:emitter
+	(multiple-value-bind
+	    (cond false)
+	    (,(symbolicate cond-kind "-CONDITION") cond)
+	  (emit-imm-inst segment ,opcode (reg-tn-encoding src)
+			 (reg-tn-encoding dst) cond
+			 (if false 1 0) ,subcode
+			 (im11-encoding imm)))))))
+
+(define-imm-inst addi add #x2D 0)
+(define-imm-inst addio add #x2D 1)
+(define-imm-inst addit add #x2C 0)
+(define-imm-inst addito add #x2C 1)
+(define-imm-inst subi compare #x25 0)
+(define-imm-inst subio compare #x25 1)
+(define-imm-inst comiclr compare #x24 0)
+
+(define-emitter emit-extract/deposit-inst 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
+  (byte 3 10) (byte 5 5) (byte 5 0))
+
+(define-instruction shd (segment r1 r2 count res &optional cond)
+  (:declare (type tn res r1 r2)
+	    (type (or (member :variable) (integer 0 31)) count))
+  (:emitter
+   (etypecase count
+     ((member :variable)
+      (emit-extract/deposit-inst segment #x34
+				 (reg-tn-encoding r2) (reg-tn-encoding r1)
+				 (extract/deposit-condition cond)
+				 0 0 (reg-tn-encoding res)))
+     ((integer 0 31)
+      (emit-extract/deposit-inst segment #x34
+				 (reg-tn-encoding r2) (reg-tn-encoding r1)
+				 (extract/deposit-condition cond)
+				 2 (- 31 count)
+				 (reg-tn-encoding res))))))
+
+(eval-when (compile eval)
+  (defmacro define-extract-inst (name opcode)
+    `(define-instruction ,name (segment src posn len res &optional cond)
+       (:declare (type tn res src)
+		 (type (or (member :variable) (integer 0 31)) posn)
+		 (type (integer 1 32) len))
+       (:emitter
+	(etypecase posn
+	  ((member :variable)
+	   (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
+				      (reg-tn-encoding res)
+				      (extract/deposit-condition cond)
+				      ,(- opcode 2) 0 (- 32 len)))
+	  ((integer 0 31)
+	   (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
+				      (reg-tn-encoding res)
+				      (extract/deposit-condition cond)
+				      ,opcode posn (- 32 len))))))))
+
+(define-extract-inst extru 6)
+(define-extract-inst extrs 7)
+
+(eval-when (compile eval)
+  (defmacro define-deposit-inst (name opcode)
+    `(define-instruction ,name (segment src posn len res &optional cond)
+       (:declare (type tn res)
+		 (type (or tn (signed-byte 5)) src)
+		 (type (or (member :variable) (integer 0 31)) posn)
+		 (type (integer 1 32) len))
+       (:emitter
+	(multiple-value-bind
+	    (opcode src-encoding)
+	    (etypecase src
+	      (tn
+	       (values ,opcode (reg-tn-encoding src)))
+	      ((signed-byte 5)
+	       (values ,(+ opcode 4) (im5-encoding src))))
+	  (multiple-value-bind
+	      (opcode posn-encoding)
+	      (etypecase posn
+		((member :variable)
+		 (values opcode 0))
+		((integer 0 31)
+		 (values (+ opcode 2) (- 31 posn))))
+	    (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
+				       src-encoding
+				       (extract/deposit-condition cond)
+				       opcode posn-encoding (- 32 len))))))))
+
+(define-deposit-inst dep 1)
+(define-deposit-inst zdep 0)
+
+
+
+;;;; System Control Instructions.
+
+(define-emitter emit-break 32
+  (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
+
+(define-instruction break (segment &optional (im5 0) (im13 0))
+  (:declare (type (unsigned-byte 13) im13)
+	    (type (unsigned-byte 5) im5))
+  (:emitter
+   (emit-break segment 0 im13 0 im5)))
+
+(define-emitter emit-system-inst 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
+
+(define-instruction ldsid (segment res base &optional (space 0))
+  (:declare (type tn res base)
+	    (type (integer 0 3) space))
+  (:emitter
+   (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
+		     (reg-tn-encoding res))))
+
+(define-instruction mtsp (segment reg space)
+  (:declare (type tn reg) (type (integer 0 7) space))
+  (:emitter
+   (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
+		     #xC1 0)))
+
+(define-instruction mfsp (segment space reg)
+  (:declare (type tn reg) (type (integer 0 7) space))
+  (:emitter
+   (emit-system-inst segment 0 0 0 (space-encoding space) #x25
+		     (reg-tn-encoding reg))))
+
+(deftype control-reg ()
+  '(or (unsigned-byte 5) (member :sar)))
+
+(defun control-reg (reg)
+  (declare (type control-reg reg)
+	   (values (unsigned-byte 32)))
+  (if (typep reg '(unsigned-byte 5))
+      reg
+      (ecase reg
+	(:sar 11))))
+
+(define-instruction mtctl (segment reg ctrl-reg)
+  (:declare (type tn reg) (type control-reg ctrl-reg))
+  (:emitter
+   (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
+		     0 #xC2 0)))
+
+(define-instruction mfctl (segment ctrl-reg reg)
+  (:declare (type tn reg) (type control-reg ctrl-reg))
+  (:emitter
+   (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
+		     (reg-tn-encoding reg))))
+
+
+
+;;;; Floating point instructions.
+
+(define-emitter emit-fp-load/store 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
+  (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
+
+(define-instruction fldx (segment index base result &key modify scale side)
+  (:declare (type tn index base result)
+	    (type (member t nil) modify scale)
+	    (type (member nil 0 1) side))
+  (:emitter
+   (multiple-value-bind
+       (result-encoding double-p)
+       (fp-reg-tn-encoding result)
+     (when side
+       (assert double-p)
+       (setf double-p nil))
+     (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
+			 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
+			 (or side 0) (if modify 1 0) result-encoding))))
+
+(define-instruction fstx (segment value index base &key modify scale side)
+  (:declare (type tn index base value)
+	    (type (member t nil) modify scale)
+	    (type (member nil 0 1) side))
+  (:emitter
+   (multiple-value-bind
+       (value-encoding double-p)
+       (fp-reg-tn-encoding value)
+     (when side
+       (assert double-p)
+       (setf double-p nil))
+     (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
+			 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
+			 (or side 0) (if modify 1 0) value-encoding))))
+  
+(define-instruction flds (segment disp base result &key modify side)
+  (:declare (type tn base result)
+	    (type (signed-byte 5) disp)
+	    (type (member :before :after nil) modify)
+	    (type (member nil 0 1) side))
+  (:emitter
+   (multiple-value-bind
+       (result-encoding double-p)
+       (fp-reg-tn-encoding result)
+     (when side
+       (assert double-p)
+       (setf double-p nil))
+     (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
+			 (short-disp-encoding segment disp) 0
+			 (if (eq modify :before) 1 0) 1 0 0
+			 (or side 0) (if modify 1 0) result-encoding))))
+
+(define-instruction fsts (segment value disp base &key modify side)
+  (:declare (type tn base value)
+	    (type (signed-byte 5) disp)
+	    (type (member :before :after nil) modify)
+	    (type (member nil 0 1) side))
+  (:emitter
+   (multiple-value-bind
+       (value-encoding double-p)
+       (fp-reg-tn-encoding value)
+     (when side
+       (assert double-p)
+       (setf double-p nil))
+     (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
+			 (short-disp-encoding segment disp) 0
+			 (if (eq modify :before) 1 0) 1 0 1
+			 (or side 0) (if modify 1 0) value-encoding))))
+
+
+(define-emitter emit-fp-class-0-inst 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
+  (byte 3 6) (byte 1 5) (byte 5 0))
+
+(define-emitter emit-fp-class-1-inst 32
+  (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
+  (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
+
+;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
+;;; seperate emitters.
+
+(defconstant funops '(:copy :abs :sqrt :rnd))
+
+(deftype funop ()
+  `(member ,@funops))
+
+(define-instruction funop (segment op from to)
+  (:declare (type funop op)
+	    (type tn from to))
+  (:emitter
+   (multiple-value-bind
+       (from-encoding from-double-p)
+       (fp-reg-tn-encoding from)
+     (multiple-value-bind
+	 (to-encoding to-double-p)
+	 (fp-reg-tn-encoding to)
+       (assert (eq from-double-p to-double-p))
+       (emit-fp-class-0-inst segment #x0C from-encoding 0
+			     (+ 2 (position op funops))
+			     (if to-double-p 1 0) 0 0 0 to-encoding)))))
+
+(eval-when (compile eval)
+  (defmacro define-class-1-fp-inst (name subcode)
+    `(define-instruction ,name (segment from to)
+       (:declare (type tn from to))
+       (:emitter
+	(multiple-value-bind
+	    (from-encoding from-double-p)
+	    (fp-reg-tn-encoding from)
+	  (multiple-value-bind
+	      (to-encoding to-double-p)
+	      (fp-reg-tn-encoding to)
+	    (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
+				  (if to-double-p 1 0) (if from-double-p 1 0)
+				  1 0 0 to-encoding)))))))
+
+(define-class-1-fp-inst fcnvff 0)
+(define-class-1-fp-inst fcnvxf 1)
+(define-class-1-fp-inst fcnvfx 2)
+(define-class-1-fp-inst fcnvfxt 3)
+
+(define-instruction fcmp (segment cond r1 r2)
+  (:declare (type (unsigned-byte 5) cond)
+	    (type tn r1 r2))
+  (:emitter
+   (multiple-value-bind
+       (r1-encoding r1-double-p)
+       (fp-reg-tn-encoding r1)
+     (multiple-value-bind
+	 (r2-encoding r2-double-p)
+	 (fp-reg-tn-encoding r2)
+       (assert (eq r1-double-p r2-double-p))
+       (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
+			     (if r1-double-p 1 0) 2 0 0 cond)))))
+
+(define-instruction ftest (segment)
+  (:emitter
+   (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
+
+(defconstant fbinops '(:add :sub :mpy :div))
+
+(deftype fbinop ()
+  `(member ,@fbinops))
+
+(define-instruction fbinop (segment op r1 r2 result)
+  (:declare (type fbinop op)
+	    (type tn r1 r2 result))
+  (:emitter
+   (multiple-value-bind
+       (r1-encoding r1-double-p)
+       (fp-reg-tn-encoding r1)
+     (multiple-value-bind
+	 (r2-encoding r2-double-p)
+	 (fp-reg-tn-encoding r2)
+       (assert (eq r1-double-p r2-double-p))
+       (multiple-value-bind
+	   (result-encoding result-double-p)
+	   (fp-reg-tn-encoding result)
+	 (assert (eq r1-double-p result-double-p))
+	 (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
+			       (position op fbinops)
+			       (if r1-double-p 1 0) 3 0 0
+			       result-encoding))))))
+
+
+
+;;;; Instructions built out of other insts.
+
+(define-instruction-macro move (src dst &optional cond)
+  `(inst or ,src zero-tn ,dst ,cond))
+
+(define-instruction-macro nop (&optional cond)
+  `(inst or zero-tn zero-tn zero-tn ,cond))
+
+(define-instruction li (segment value reg)
+  (:declare (type tn reg)
+	    (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
+  (:vop-var vop)
+  (:emitter
+   (assemble (segment vop)
+     (etypecase value
+       (fixup
+	(inst ldil value reg)
+	(inst ldo value reg reg))
+       ((signed-byte 14)
+	(inst ldo value zero-tn reg))
+       ((or (signed-byte 32) (unsigned-byte 32))
+	(let ((hi (ldb (byte 21 11) value))
+	      (lo (ldb (byte 11 0) value)))
+	  (inst ldil hi reg)
+	  (unless (zerop lo)
+	    (inst ldo lo reg reg))))))))
+
+(define-instruction-macro sll (src count result &optional cond)
+  (once-only ((result result) (src src) (count count) (cond cond))
+    `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
+
+(define-instruction-macro sra (src count result &optional cond)
+  (once-only ((result result) (src src) (count count) (cond cond))
+    `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
+
+(define-instruction-macro srl (src count result &optional cond)
+  (once-only ((result result) (src src) (count count) (cond cond))
+    `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
+
+(defun maybe-negate-cond (cond negate)
+  (if negate
+      (multiple-value-bind
+	  (value negate)
+	  (compare-condition cond)
+	(if negate
+	    (nth value compare-conditions)
+	    (nth (+ value 8) compare-conditions)))
+      cond))
+
+(define-instruction bc (segment cond not-p r1 r2 target)
+  (:declare (type compare-condition cond)
+	    (type (member t nil) not-p)
+	    (type tn r1 r2)
+	    (type label target))
+  (:vop-var vop)
+  (:emitter
+   (emit-chooser segment 8 2
+     #'(lambda (segment posn delta)
+	 (let ((disp (label-relative-displacement target posn delta)))
+	   (when (<= 0 disp (1- (ash 1 11)))
+	     (assemble (segment vop)
+	       (inst comb (maybe-negate-cond cond not-p) r1 r2 target
+		     :nullify t))
+	     t)))
+     #'(lambda (segment posn)
+	 (let ((disp (label-relative-displacement target posn)))
+	   (assemble (segment vop)
+	     (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
+		    (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
+		    (inst nop))
+		   (t
+		    (inst comclr r1 r2 zero-tn
+			  (maybe-negate-cond cond (not not-p)))
+		    (inst b target :nullify t)))))))))
+
+(define-instruction bci (segment cond not-p imm reg target)
+  (:declare (type compare-condition cond)
+	    (type (member t nil) not-p)
+	    (type (signed-byte 11) imm)
+	    (type tn reg)
+	    (type label target))
+  (:vop-var vop)
+  (:emitter
+   (emit-chooser segment 8 2
+     #'(lambda (segment posn delta-if-after)
+	 (let ((disp (label-relative-displacement target posn delta-if-after)))
+	   (when (and (<= 0 disp (1- (ash 1 11)))
+		      (<= (- (ash 1 4)) imm (1- (ash 1 4))))
+	     (assemble (segment vop)
+	       (inst comib (maybe-negate-cond cond not-p) imm reg target
+		     :nullify t))
+	     t)))
+     #'(lambda (segment posn)
+	 (let ((disp (label-relative-displacement target posn)))
+	   (assemble (segment vop)
+	     (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
+			 (<= (- (ash 1 4)) imm (1- (ash 1 4))))
+		    (inst comib (maybe-negate-cond cond not-p) imm reg target)
+		    (inst nop))
+		   (t
+		    (inst comiclr imm reg zero-tn
+			  (maybe-negate-cond cond (not not-p)))
+		    (inst b target :nullify t)))))))))
+
+
+;;;; Instructions to convert between code ptrs, functions, and lras.
+
+(defun emit-compute-inst (segment vop src label temp dst calc)
+  (emit-chooser
+      ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
+      segment 12 3
+    #'(lambda (segment posn delta-if-after)
+	(let ((delta (funcall calc label posn delta-if-after)))
+	  (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
+	    (emit-back-patch segment 4
+			     #'(lambda (segment posn)
+				 (assemble (segment vop)
+				   (inst addi (funcall calc label posn 0) src
+					 dst))))
+	    t)))
+    #'(lambda (segment posn)
+	(let ((delta (funcall calc label posn 0)))
+	  ;; Note: if we used addil/ldo to do this in 2 instructions then the
+	  ;; intermediate value would be tagged but pointing into space.
+	  (assemble (segment vop)
+	    (inst ldil (ldb (byte 21 11) delta) temp)
+	    (inst ldo (ldb (byte 11 0) delta) temp temp)
+	    (inst add src temp dst))))))
+
+;; code = fn - header - label-offset + other-pointer-tag
+(define-instruction compute-code-from-fn (segment src label temp dst)
+  (:declare (type tn src dst temp)
+	    (type label label))
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop src label temp dst
+		      #'(lambda (label posn delta-if-after)
+			  (- other-pointer-type
+			     (label-position label posn delta-if-after)
+			     (component-header-length))))))
+
+;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
+(define-instruction compute-code-from-lra (segment src label temp dst)
+  (:declare (type tn src dst temp)
+	    (type label label))
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop src label temp dst
+		      #'(lambda (label posn delta-if-after)
+			  (- (+ (label-position label posn delta-if-after)
+				(component-header-length)))))))
+
+;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
+(define-instruction compute-lra-from-code (segment src label temp dst)
+  (:declare (type tn src dst temp)
+	    (type label label))
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop src label temp dst
+		      #'(lambda (label posn delta-if-after)
+			  (+ (label-position label posn delta-if-after)
+			     (component-header-length))))))
+
+
+;;;; Data instructions.
+
+(define-instruction byte (segment byte)
+  (:emitter
+   (emit-byte segment byte)))
+
+(define-emitter emit-halfword 16
+  (byte 16 0))
+
+(define-instruction halfword (segment halfword)
+  (:emitter
+   (emit-halfword segment halfword)))
+
+(define-emitter emit-word 32
+  (byte 32 0))
+
+(define-instruction word (segment word)
+  (:emitter
+   (emit-word segment word)))
+
+(define-instruction function-header-word (segment)
+  (:emitter
+   (emit-back-patch
+    segment 4
+    #'(lambda (segment posn)
+	(emit-word segment
+		   (logior function-header-type
+			   (ash (+ posn (component-header-length))
+				(- type-bits word-shift))))))))
+
+(define-instruction lra-header-word (segment)
+  (:emitter
+   (emit-back-patch
+    segment 4
+    #'(lambda (segment posn)
+	(emit-word segment
+		   (logior return-pc-header-type
+			   (ash (+ posn (component-header-length))
+				(- type-bits word-shift))))))))
diff --git a/compiler/hppa/macros.lisp b/compiler/hppa/macros.lisp
new file mode 100644
index 000000000..3d41dabf3
--- /dev/null
+++ b/compiler/hppa/macros.lisp
@@ -0,0 +1,402 @@
+;;; -*- Package: hppa -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/macros.lisp,v 1.1 1992/07/13 03:48:24 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains various useful macros for generating HP-PA code.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package :hppa)
+
+
+;;; Instruction-like macros.
+
+(defmacro move (src dst)
+  "Move SRC into DST unless they are location=."
+  (once-only ((src src) (dst dst))
+    `(unless (location= ,src ,dst)
+       (inst move ,src ,dst))))
+
+(defmacro loadw (result base &optional (offset 0) (lowtag 0))
+  (once-only ((result result) (base base))
+    `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result)))
+
+(defmacro storew (value base &optional (offset 0) (lowtag 0))
+  (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
+    `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
+
+(defmacro load-symbol (reg symbol)
+  (once-only ((reg reg) (symbol symbol))
+    `(inst addi (static-symbol-offset ,symbol) null-tn ,reg)))
+
+(defmacro load-symbol-value (reg symbol)
+  `(inst ldw
+	 (+ (static-symbol-offset ',symbol)
+	    (ash symbol-value-slot word-shift)
+	    (- other-pointer-type))
+	 null-tn
+	 ,reg))
+
+(defmacro store-symbol-value (reg symbol)
+  `(inst stw ,reg (+ (static-symbol-offset ',symbol)
+		     (ash symbol-value-slot word-shift)
+		     (- other-pointer-type))
+	 null-tn))
+
+(defmacro load-type (target source &optional (offset 0))
+  "Loads the type bits of a pointer into target independent of
+   byte-ordering issues."
+  (ecase (backend-byte-order *target-backend*)
+    (:little-endian
+     `(inst ldb ,offset ,source ,target))
+    (:big-endian
+     `(inst ldb (+ ,offset 3) ,source ,target))))
+
+;;; Macros to handle the fact that we cannot use the machine native call and
+;;; return instructions. 
+
+(defmacro lisp-jump (function)
+  "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
+  `(progn
+     (inst addi
+	   (- (ash function-header-code-offset word-shift)
+	      function-pointer-type)
+	   ,function
+	   lip-tn)
+     (inst bv lip-tn)
+     (move ,function code-tn)))
+
+(defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
+  "Return to RETURN-PC."
+  `(progn
+     (inst addi (- (* (1+ ,offset) word-bytes) other-pointer-type)
+	   ,return-pc lip-tn)
+     (inst bv lip-tn ,@(unless frob-code '(:nullify t)))
+     ,@(when frob-code
+	 `((move ,return-pc code-tn)))))
+
+(defmacro emit-return-pc (label)
+  "Emit a return-pc header word.  LABEL is the label to use for this
+   return-pc."
+  `(progn
+     (align lowtag-bits)
+     (emit-label ,label)
+     (inst lra-header-word)))
+
+
+;;;; Stack TN's
+
+;;; Load-Stack-TN, Store-Stack-TN  --  Interface
+;;;
+;;;    Move a stack TN to a register and vice-versa.
+;;;
+(defmacro load-stack-tn (reg stack)
+  `(let ((reg ,reg)
+	 (stack ,stack))
+     (let ((offset (tn-offset stack)))
+       (sc-case stack
+	 ((control-stack)
+	  (loadw reg cfp-tn offset))))))
+
+(defmacro store-stack-tn (stack reg)
+  `(let ((stack ,stack)
+	 (reg ,reg))
+     (let ((offset (tn-offset stack)))
+       (sc-case stack
+	 ((control-stack)
+	  (storew reg cfp-tn offset))))))
+
+
+;;; MAYBE-LOAD-STACK-TN  --  Interface
+;;;
+(defmacro maybe-load-stack-tn (reg reg-or-stack)
+  "Move the TN Reg-Or-Stack into Reg if it isn't already there."
+  (once-only ((n-reg reg)
+	      (n-stack reg-or-stack))
+    `(sc-case ,n-reg
+       ((any-reg descriptor-reg)
+	(sc-case ,n-stack
+	  ((any-reg descriptor-reg)
+	   (move ,n-stack ,n-reg))
+	  ((control-stack)
+	   (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
+
+
+;;;; Storage allocation:
+
+(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
+				 &body body)
+  "Do stuff to allocate an other-pointer object of fixed Size with a single
+  word header having the specified Type-Code.  The result is placed in
+  Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
+  by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
+  initializes the object."
+  (once-only ((result-tn result-tn) (temp-tn temp-tn)
+	      (type-code type-code) (size size))
+    `(pseudo-atomic (:extra (pad-data-block ,size))
+       (inst move alloc-tn ,result-tn)
+       (inst dep other-pointer-type 31 3 ,result-tn)
+       (inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn)
+       (storew ,temp-tn ,result-tn 0 other-pointer-type)
+       ,@body)))
+
+
+;;;; Error Code
+
+(defvar *adjustable-vectors* nil)
+
+(defmacro with-adjustable-vector ((var) &rest body)
+  `(let ((,var (or (pop *adjustable-vectors*)
+		   (make-array 16
+			       :element-type '(unsigned-byte 8)
+			       :fill-pointer 0
+			       :adjustable t))))
+     (setf (fill-pointer ,var) 0)
+     (unwind-protect
+	 (progn
+	   ,@body)
+       (push ,var *adjustable-vectors*))))
+
+(eval-when (compile load eval)
+  (defun emit-error-break (vop kind code values)
+    (let ((vector (gensym)))
+      `((let ((vop ,vop))
+	  (when vop
+	    (note-this-location vop :internal-error)))
+	(inst break ,kind)
+	(with-adjustable-vector (,vector)
+	  (write-var-integer (error-number-or-lose ',code) ,vector)
+	  ,@(mapcar #'(lambda (tn)
+			`(let ((tn ,tn))
+			   (write-var-integer (make-sc-offset (sc-number
+							       (tn-sc tn))
+							      (tn-offset tn))
+					      ,vector)))
+		    values)
+	  (inst byte (length ,vector))
+	  (dotimes (i (length ,vector))
+	    (inst byte (aref ,vector i))))
+	(align word-shift)))))
+
+(defmacro error-call (vop error-code &rest values)
+  "Cause an error.  ERROR-CODE is the error to cause."
+  (cons 'progn
+	(emit-error-break vop error-trap error-code values)))
+
+
+(defmacro cerror-call (vop label error-code &rest values)
+  "Cause a continuable error.  If the error is continued, execution resumes at
+  LABEL."
+  `(progn
+     (inst b ,label)
+     ,@(emit-error-break vop cerror-trap error-code values)))
+
+(defmacro generate-error-code (vop error-code &rest values)
+  "Generate-Error-Code Error-code Value*
+  Emit code for an error with the specified Error-Code and context Values."
+  `(assemble (*elsewhere*)
+     (let ((start-lab (gen-label)))
+       (emit-label start-lab)
+       (error-call ,vop ,error-code ,@values)
+       start-lab)))
+
+(defmacro generate-cerror-code (vop error-code &rest values)
+  "Generate-CError-Code Error-code Value*
+  Emit code for a continuable error with the specified Error-Code and
+  context Values.  If the error is continued, execution resumes after
+  the GENERATE-CERROR-CODE form."
+  (let ((continue (gensym "CONTINUE-LABEL-"))
+	(error (gensym "ERROR-LABEL-")))
+    `(let ((,continue (gen-label)))
+       (emit-label ,continue)
+       (assemble (*elsewhere*)
+	 (let ((,error (gen-label)))
+	   (emit-label ,error)
+	   (cerror-call ,vop ,continue ,error-code ,@values)
+	   ,error)))))
+
+
+
+;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
+;;;
+(defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
+  (let ((n-extra (gensym)))
+    `(let ((,n-extra ,extra))
+       (inst addi 4 alloc-tn alloc-tn)
+       ,@forms
+       (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
+
+
+
+;;;; Indexed references:
+
+(deftype load/store-index (scale lowtag min-offset
+				 &optional (max-offset min-offset))
+  `(integer ,(- (truncate (+ (ash 1 14)
+			     (* min-offset word-bytes)
+			     (- lowtag))
+			  scale))
+	    ,(truncate (- (+ (1- (ash 1 14)) lowtag)
+			  (* max-offset word-bytes))
+		       scale)))
+
+(defmacro define-full-reffer (name type offset lowtag scs el-type
+				   &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg) :to (:eval 0))
+	      (index :scs (any-reg) :target temp))
+       (:arg-types ,type tagged-num)
+       (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 5
+	 (inst addi (- (* ,offset word-bytes) ,lowtag) index temp)
+	 (inst ldwx temp object value)))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg)))
+       (:info index)
+       (:arg-types ,type
+		   (:constant (load/store-index ,word-bytes ,(eval lowtag)
+						,(eval offset))))
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 4
+	 (inst ldw (- (* (+ ,offset index) word-bytes) ,lowtag)
+	       object value)))))
+
+(defmacro define-full-setter (name type offset lowtag scs el-type
+				   &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg))
+	      (value :scs ,scs :target result))
+       (:arg-types ,type tagged-num ,el-type)
+       (:temporary (:scs (interior-reg)) lip)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 2
+	 (inst add object index lip)
+	 (inst stw value (- (* ,offset word-bytes) ,lowtag) lip)
+	 (move value result)))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (value :scs ,scs))
+       (:info index)
+       (:arg-types ,type
+		   (:constant (load/store-index ,word-bytes ,(eval lowtag)
+						,(eval offset)))
+		   ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 1
+	 (inst stw value (- (* (+ ,offset index) word-bytes) ,lowtag) object)
+	 (move value result)))))
+
+
+(defmacro define-partial-reffer (name type size signed offset lowtag scs
+				      el-type &optional translate)
+  `(progn
+     (define-vop (,name)
+		 ,@(when translate
+		     `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg) :to (:eval 0))
+	      (index :scs (unsigned-reg)))
+       (:arg-types ,type positive-fixnum)
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:temporary (:scs (interior-reg)) lip)
+       (:generator 5
+	 (inst ,(ecase size (:byte 'add) (:short 'sh1add))
+	       index object lip)
+	 (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
+	       (- (* ,offset word-bytes) ,lowtag) lip value)
+	 ,@(when signed
+	     `((inst extrs value 31 ,(ecase size (:byte 8) (:short 16))
+		     value)))))
+     (define-vop (,(symbolicate name "-C"))
+		 ,@(when translate
+		     `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg)))
+       (:info index)
+       (:arg-types ,type
+		   (:constant (load/store-index ,(ecase size
+						   (:byte 1)
+						   (:short 2))
+						,(eval lowtag)
+						,(eval offset))))
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 5
+	 (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
+	       (- (* (+ ,offset index) word-bytes) ,lowtag) object value)
+	 ,@(when signed
+	     `((inst extrs value 31 ,(ecase size (:byte 8) (:short 16))
+		     value)))))))
+
+(defmacro define-partial-setter (name type size offset lowtag scs el-type
+				      &optional translate)
+  `(progn
+     (define-vop (,name)
+		 ,@(when translate
+		     `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (unsigned-reg))
+	      (value :scs ,scs :target result))
+       (:arg-types ,type positive-fixnum ,el-type)
+       (:temporary (:scs (interior-reg)) lip)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 5
+	 (inst ,(ecase size (:byte 'add) (:short 'sh1add))
+	       index object lip)
+	 (inst ,(ecase size (:byte 'stb) (:short 'sth))
+	       value (- (* ,offset word-bytes) ,lowtag) lip)
+	 (move value result)))
+     (define-vop (,(symbolicate name "-C"))
+		 ,@(when translate
+		     `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (value :scs ,scs :target result))
+       (:info index)
+       (:arg-types ,type
+		   (:constant (load/store-index ,(ecase size
+						   (:byte 1)
+						   (:short 2))
+						,(eval lowtag)
+						,(eval offset)))
+		   ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 5
+	 (inst ,(ecase size (:byte 'stb) (:short 'sth))
+	       value (- (* (+ ,offset index) word-bytes) ,lowtag) object)
+	 (move value result)))))
+
diff --git a/compiler/hppa/memory.lisp b/compiler/hppa/memory.lisp
new file mode 100644
index 000000000..de1eadf77
--- /dev/null
+++ b/compiler/hppa/memory.lisp
@@ -0,0 +1,106 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/memory.lisp,v 1.1 1992/07/13 03:48:26 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the HPPA definitions of some general purpose memory
+;;; reference VOPs inherited by basic memory reference operations.
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "HPPA")
+
+;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to
+;;; be read or written is a property of the VOP used.  Cell-Setf is similar to
+;;; Cell-Set, but delivers the new value as the result.  Cell-Setf-Function
+;;; takes its arguments as if it were a setf function (new value first, as
+;;; apposed to a setf macro, which takes the new value last).
+;;;
+(define-vop (cell-ref)
+  (:args (object :scs (descriptor-reg)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (loadw value object offset lowtag)))
+;;;
+(define-vop (cell-set)
+  (:args (object :scs (descriptor-reg))
+         (value :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 1
+    (storew value object offset lowtag)))
+;;;
+(define-vop (cell-setf)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg)
+		:target result))
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 1
+    (storew value object offset lowtag)
+    (move value result)))
+;;;
+(define-vop (cell-setf-function)
+  (:args (value :scs (descriptor-reg any-reg)
+		:target result)
+	 (object :scs (descriptor-reg)))
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 1
+    (storew value object offset lowtag)
+    (move value result)))
+
+;;; Define-Cell-Accessors  --  Interface
+;;;
+;;;    Define accessor VOPs for some cells in an object.  If the operation name
+;;; is NIL, then that operation isn't defined.  If the translate function is
+;;; null, then we don't define a translation.
+;;;
+(defmacro define-cell-accessors (offset lowtag
+					ref-op ref-trans set-op set-trans)
+  `(progn
+     ,@(when ref-op
+	 `((define-vop (,ref-op cell-ref)
+	     (:variant ,offset ,lowtag)
+	     ,@(when ref-trans
+		 `((:translate ,ref-trans))))))
+     ,@(when set-op
+	 `((define-vop (,set-op cell-setf)
+	     (:variant ,offset ,lowtag)
+	     ,@(when set-trans
+		 `((:translate ,set-trans))))))))
+
+
+;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the
+;;; offset is constant at compile time, but varies for different uses.  We add
+;;; in the stardard g-vector overhead.
+;;;
+(define-vop (slot-ref)
+  (:args (object :scs (descriptor-reg)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 4
+    (loadw value object (+ base offset) lowtag)))
+;;;
+(define-vop (slot-set)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg)))
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 1
+    (storew value object (+ base offset) lowtag)))
+
diff --git a/compiler/hppa/move.lisp b/compiler/hppa/move.lisp
new file mode 100644
index 000000000..a6cb098f0
--- /dev/null
+++ b/compiler/hppa/move.lisp
@@ -0,0 +1,309 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/move.lisp,v 1.1 1992/07/13 03:48:27 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the HPPA VM definition of operand loading/saving and
+;;; the Move VOP.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "HPPA")
+
+
+(define-move-function (load-immediate 1) (vop x y)
+  ((null zero immediate)
+   (any-reg descriptor-reg))
+  (let ((val (tn-value x)))
+    (etypecase val
+      (integer
+       (inst li (fixnum val) y))
+      (null
+       (move null-tn y))
+      (symbol
+       (load-symbol y val))
+      (character
+       (inst li (logior (ash (char-code val) type-bits)
+			base-char-type)
+	     y)))))
+
+(define-move-function (load-number 1) (vop x y)
+  ((immediate zero)
+   (signed-reg unsigned-reg))
+  (let ((x (tn-value x)))
+    (inst li (if (>= x (ash 1 31)) (logior (ash -1 32) x) x) y)))
+
+(define-move-function (load-base-char 1) (vop x y)
+  ((immediate) (base-char-reg))
+  (inst li (char-code (tn-value x)) y))
+
+(define-move-function (load-system-area-pointer 1) (vop x y)
+  ((immediate) (sap-reg))
+  (inst li (sap-int (tn-value x)) y))
+
+(define-move-function (load-constant 5) (vop x y)
+  ((constant) (descriptor-reg))
+  (loadw y code-tn (tn-offset x) other-pointer-type))
+
+(define-move-function (load-stack 5) (vop x y)
+  ((control-stack) (any-reg descriptor-reg))
+  (load-stack-tn y x))
+
+(define-move-function (load-number-stack 5) (vop x y)
+  ((base-char-stack) (base-char-reg)
+   (sap-stack) (sap-reg)
+   (signed-stack) (signed-reg)
+   (unsigned-stack) (unsigned-reg))
+  (let ((nfp (current-nfp-tn vop)))
+    (loadw y nfp (tn-offset x))))
+
+(define-move-function (store-stack 5) (vop x y)
+  ((any-reg descriptor-reg) (control-stack))
+  (store-stack-tn y x))
+
+(define-move-function (store-number-stack 5) (vop x y)
+  ((base-char-reg) (base-char-stack)
+   (sap-reg) (sap-stack)
+   (signed-reg) (signed-stack)
+   (unsigned-reg) (unsigned-stack))
+  (let ((nfp (current-nfp-tn vop)))
+    (storew x nfp (tn-offset y))))
+
+
+;;;; The Move VOP:
+;;;
+(define-vop (move)
+  (:args (x :target y
+	    :scs (any-reg descriptor-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (any-reg descriptor-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move x y)))
+
+(define-move-vop move :move
+  (any-reg descriptor-reg)
+  (any-reg descriptor-reg))
+
+;;; Make Move the check VOP for T so that type check generation doesn't think
+;;; it is a hairy type.  This also allows checking of a few of the values in a
+;;; continuation to fall out.
+;;;
+(primitive-type-vop move (:check) t)
+
+;;;    The Move-Argument VOP is used for moving descriptor values into another
+;;; frame for argument or known value passing.
+;;;
+(define-vop (move-argument)
+  (:args (x :target y
+	    :scs (any-reg descriptor-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y any-reg descriptor-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      ((any-reg descriptor-reg)
+       (move x y))
+      (control-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-argument :move-argument
+  (any-reg descriptor-reg)
+  (any-reg descriptor-reg))
+
+
+
+;;;; ILLEGAL-MOVE
+
+;;; This VOP exists just to begin the lifetime of a TN that couldn't be written
+;;; legally due to a type error.  An error is signalled before this VOP is
+;;; so we don't need to do anything (not that there would be anything sensible
+;;; to do anyway.)
+;;;
+(define-vop (illegal-move)
+  (:args (x) (type))
+  (:results (y))
+  (:ignore y)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 666
+    (error-call vop object-not-type-error x type)))
+
+
+
+;;;; Moves and coercions:
+
+;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
+;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
+;;; to a tagged bignum or fixnum.
+
+;;; Arg is a fixnum, so just shift it.  We need a type restriction because some
+;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
+;;;
+(define-vop (move-to-word/fixnum)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:arg-types tagged-num)
+  (:note "fixnum untagging")
+  (:generator 1
+    (inst sra x 2 y)))
+;;;
+(define-move-vop move-to-word/fixnum :move
+  (any-reg descriptor-reg) (signed-reg unsigned-reg))
+
+;;; Arg is a non-immediate constant, load it.
+(define-vop (move-to-word-c)
+  (:args (x :scs (constant)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note "constant load")
+  (:generator 1
+    (inst li (tn-value x) y)))
+;;;
+(define-move-vop move-to-word-c :move
+  (constant) (signed-reg unsigned-reg))
+
+;;; Arg is a fixnum or bignum, figure out which and load if necessary.
+(define-vop (move-to-word/integer)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note "integer to untagged word coercion")
+  (:generator 3
+    (inst extru x 31 2 zero-tn :<>)
+    (inst sra x 2 y :tr)
+    (loadw y x vm:bignum-digits-offset vm:other-pointer-type)))
+;;;
+(define-move-vop move-to-word/integer :move
+  (descriptor-reg) (signed-reg unsigned-reg))
+
+;;; Result is a fixnum, so we can just shift.  We need the result type
+;;; restriction because of the control-stack ambiguity noted above.
+;;;
+(define-vop (move-from-word/fixnum)
+  (:args (x :scs (signed-reg unsigned-reg)))
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note "fixnum tagging")
+  (:generator 1
+    (inst sll x 2 y)))
+;;;
+(define-move-vop move-from-word/fixnum :move
+  (signed-reg unsigned-reg) (any-reg descriptor-reg))
+
+;;; Result may be a bignum, so we have to check.  Use a worst-case cost to make
+;;; sure people know they may be number consing.
+;;;
+(define-vop (move-from-signed)
+  (:args (x :scs (signed-reg unsigned-reg) :to (:eval 1)))
+  (:results (y :scs (any-reg descriptor-reg) :from (:eval 0)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:note "signed word to integer coercion")
+  (:generator 18
+    ;; Extract the top three bits.
+    (inst extrs x 2 3 temp :=)
+    ;; Invert them (unless they are already zero).
+    (inst uaddcm zero-tn temp temp)
+    ;; If we are left with zero, it will fit in a fixnum.  So branch around
+    ;; the bignum-construction, doing the shift in the delay slot.
+    (inst comb := temp zero-tn done)
+    (inst sll x 2 y)
+    ;; Make a single-digit bignum.
+    (with-fixed-allocation (y temp bignum-type (1+ bignum-digits-offset))
+      (storew x y bignum-digits-offset other-pointer-type))
+    DONE))
+;;;
+(define-move-vop move-from-signed :move
+  (signed-reg) (descriptor-reg))
+
+
+;;; Check for fixnum, and possibly allocate one or two word bignum result.  Use
+;;; a worst-case cost to make sure people know they may be number consing.
+;;;
+(define-vop (move-from-unsigned)
+  (:args (x :scs (signed-reg unsigned-reg) :to (:eval 1)))
+  (:results (y :scs (any-reg descriptor-reg) :from (:eval 0)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:note "unsigned word to integer coercion")
+  (:generator 20
+    ;; Grab the top three bits.
+    (inst extrs x 2 3 temp)
+    ;; If zero, it will fit as a fixnum.
+    (inst comib := 0 temp done)
+    (inst sll x 2 y)
+    ;; Make a bignum.
+    (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
+      ;; Create the result pointer.
+      (inst move alloc-tn y)
+      (inst dep other-pointer-type 31 3 y)
+      ;; Check the high bit, and skip the next instruction it it's 0.
+      (inst comclr x zero-tn zero-tn :>=)
+      ;; The high bit is set, so allocate enough space for a two-word bignum.
+      ;; We always skip the following instruction, so it is only executed
+      ;; when we want one word.
+      (inst addi (pad-data-block 1) alloc-tn alloc-tn :tr)
+      ;; Set up the header for one word.  Use addi instead of li so we can
+      ;; skip the next instruction.
+      (inst addi (logior (ash 1 type-bits) bignum-type) zero-tn temp :tr)
+      ;; Set up the header for two words.
+      (inst li (logior (ash 2 type-bits) bignum-type) temp)
+      ;; Store the header and the data.
+      (storew temp y 0 other-pointer-type)
+      (storew x y bignum-digits-offset other-pointer-type))
+    DONE))
+;;;
+(define-move-vop move-from-unsigned :move
+  (unsigned-reg) (descriptor-reg))
+
+
+;;; Move untagged numbers.
+;;;
+(define-vop (word-move)
+  (:args (x :target y
+	    :scs (signed-reg unsigned-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (signed-reg unsigned-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:note "word integer move")
+  (:generator 0
+    (move x y)))
+;;;
+(define-move-vop word-move :move
+  (signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+
+;;; Move untagged number arguments/return-values.
+;;;
+(define-vop (move-word-argument)
+  (:args (x :target y
+	    :scs (signed-reg unsigned-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:note "word integer argument move")
+  (:generator 0
+    (sc-case y
+      ((signed-reg unsigned-reg)
+       (move x y))
+      ((signed-stack unsigned-stack)
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-word-argument :move-argument
+  (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (signed-reg unsigned-reg) (any-reg descriptor-reg))
diff --git a/compiler/hppa/nlx.lisp b/compiler/hppa/nlx.lisp
new file mode 100644
index 000000000..a417745b2
--- /dev/null
+++ b/compiler/hppa/nlx.lisp
@@ -0,0 +1,273 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/nlx.lisp,v 1.1 1992/07/13 03:48:28 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the definitions of VOPs used for non-local exit
+;;; (throw, lexical exit, etc.)
+;;;
+;;; Written by William Lott
+;;;
+(in-package "HPPA")
+
+;;; MAKE-NLX-SP-TN  --  Interface
+;;;
+;;;    Make an environment-live stack TN for saving the SP for NLX entry.
+;;;
+(def-vm-support-routine make-nlx-sp-tn (env)
+  (environment-live-tn
+   (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
+   env))
+
+
+
+;;; Save and restore dynamic environment.
+;;;
+;;;    These VOPs are used in the reentered function to restore the appropriate
+;;; dynamic environment.  Currently we only save the Current-Catch and binding
+;;; stack pointer.  We don't need to save/restore the current unwind-protect,
+;;; since unwind-protects are implicitly processed during unwinding.  If there
+;;; were any additional stacks, then this would be the place to restore the top
+;;; pointers.
+
+
+;;; Make-Dynamic-State-TNs  --  Interface
+;;;
+;;;    Return a list of TNs that can be used to snapshot the dynamic state for
+;;; use with the Save/Restore-Dynamic-Environment VOPs.
+;;;
+(def-vm-support-routine make-dynamic-state-tns ()
+  (make-n-tns 4 *any-primitive-type*))
+
+(define-vop (save-dynamic-state)
+  (:results (catch :scs (descriptor-reg))
+	    (nfp :scs (descriptor-reg))
+	    (nsp :scs (descriptor-reg))
+	    (eval :scs (descriptor-reg)))
+  (:vop-var vop)
+  (:generator 13
+    (load-symbol-value catch lisp::*current-catch-block*)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(move cur-nfp nfp)))
+    (move nsp-tn nsp)
+    (load-symbol-value eval lisp::*eval-stack-top*)))
+
+(define-vop (restore-dynamic-state)
+  (:args (catch :scs (descriptor-reg))
+	 (nfp :scs (descriptor-reg))
+	 (nsp :scs (descriptor-reg))
+	 (eval :scs (descriptor-reg)))
+  (:vop-var vop)
+  (:generator 10
+    (store-symbol-value catch lisp::*current-catch-block*)
+    (store-symbol-value eval lisp::*eval-stack-top*)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(move nfp cur-nfp)))
+    (move nsp nsp-tn)))
+
+(define-vop (current-stack-pointer)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (move csp-tn res)))
+
+(define-vop (current-binding-pointer)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (move bsp-tn res)))
+
+
+;;;; Unwind block hackery:
+
+;;; Compute the address of the catch block from its TN, then store into the
+;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
+;;;
+(define-vop (make-unwind-block)
+  (:args (tn))
+  (:info entry-label)
+  (:results (block :scs (any-reg)))
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:generator 22
+    (inst addi (* (tn-offset tn) word-bytes) cfp-tn block)
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp block unwind-block-current-uwp-slot)
+    (storew cfp-tn block unwind-block-current-cont-slot)
+    (storew code-tn block unwind-block-current-code-slot)
+    (inst compute-lra-from-code code-tn entry-label ndescr temp)
+    (storew temp block catch-block-entry-pc-slot)))
+
+;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
+;;; link the block into the Current-Catch list.
+;;;
+(define-vop (make-catch-block)
+  (:args (tn)
+	 (tag :scs (descriptor-reg)))
+  (:info entry-label)
+  (:results (block :scs (any-reg) :from (:argument 0)))
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:generator 44
+    (inst addi (* (tn-offset tn) word-bytes) cfp-tn block)
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp block catch-block-current-uwp-slot)
+    (storew cfp-tn block catch-block-current-cont-slot)
+    (storew code-tn block catch-block-current-code-slot)
+    (inst compute-lra-from-code code-tn entry-label ndescr temp)
+    (storew temp block catch-block-entry-pc-slot)
+
+    (storew tag block catch-block-tag-slot)
+    (load-symbol-value temp lisp::*current-catch-block*)
+    (storew temp block catch-block-previous-catch-slot)
+    (store-symbol-value block lisp::*current-catch-block*)))
+
+
+;;; Just set the current unwind-protect to TN's address.  This instantiates an
+;;; unwind block as an unwind-protect.
+;;;
+(define-vop (set-unwind-protect)
+  (:args (tn))
+  (:temporary (:scs (descriptor-reg)) new-uwp)
+  (:generator 7
+    (inst addi (* (tn-offset tn) word-bytes) cfp-tn new-uwp)
+    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
+
+
+(define-vop (unlink-catch-block)
+  (:temporary (:scs (any-reg)) block)
+  (:policy :fast-safe)
+  (:translate %catch-breakup)
+  (:generator 17
+    (load-symbol-value block lisp::*current-catch-block*)
+    (loadw block block catch-block-previous-catch-slot)
+    (store-symbol-value block lisp::*current-catch-block*)))
+
+(define-vop (unlink-unwind-protect)
+  (:temporary (:scs (any-reg)) block)
+  (:policy :fast-safe)
+  (:translate %unwind-protect-breakup)
+  (:generator 17
+    (load-symbol-value block lisp::*current-unwind-protect-block*)
+    (loadw block block unwind-block-current-uwp-slot)
+    (store-symbol-value block lisp::*current-unwind-protect-block*)))
+
+
+;;;; NLX entry VOPs:
+
+
+(define-vop (nlx-entry)
+  (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
+	      ; would be inserted before the LRA.
+	 (start)
+	 (count))
+  (:results (values :more t))
+  (:temporary (:scs (descriptor-reg)) move-temp)
+  (:info label nvals)
+  (:save-p :force-to-stack)
+  (:vop-var vop)
+  (:generator 30
+    (emit-return-pc label)
+    (note-this-location vop :non-local-entry)
+    (cond ((zerop nvals))
+	  ((= nvals 1)
+	   (inst comclr count zero-tn zero-tn :<>)
+	   (inst move null-tn (tn-ref-tn values) :tr)
+	   (loadw (tn-ref-tn values) start))
+	  (t
+	   (collect ((defaults))
+	     (do ((i 0 (1+ i))
+		  (tn-ref values (tn-ref-across tn-ref)))
+		 ((null tn-ref))
+	       (let ((default-lab (gen-label))
+		     (tn (tn-ref-tn tn-ref)))
+		 (defaults (cons default-lab tn))
+
+		 (inst bci := nil (fixnum i) count default-lab)
+		 (sc-case tn
+		   ((descriptor-reg any-reg)
+		    (loadw tn start i))
+		   (control-stack
+		    (loadw move-temp start i)
+		    (store-stack-tn tn move-temp)))))
+	     
+	     (let ((defaulting-done (gen-label)))
+	       (emit-label defaulting-done)
+	       
+	       (assemble (*elsewhere*)
+		 (do ((defs (defaults) (cdr defs)))
+		     ((null defs))
+		   (let ((def (car defs)))
+		     (emit-label (car def))
+		     (unless (cdr defs)
+		       (inst b defaulting-done))
+		     (let ((tn (cdr def)))
+		       (sc-case tn
+			 ((descriptor-reg any-reg)
+			  (move null-tn tn))
+			 (control-stack
+			  (store-stack-tn tn null-tn)))))))))))
+    (load-stack-tn csp-tn sp)))
+
+
+(define-vop (nlx-entry-multiple)
+  (:args (top :target dst) (start :target src) (count :target num))
+  ;; Again, no SC restrictions for the args, 'cause the loading would
+  ;; happen before the entry label.
+  (:info label)
+  (:temporary (:scs (any-reg) :from (:argument 0)) dst)
+  (:temporary (:scs (any-reg) :from (:argument 1)) src)
+  (:temporary (:scs (any-reg) :from (:argument 2)) num)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:results (new-start) (new-count))
+  (:save-p :force-to-stack)
+  (:vop-var vop)
+  (:generator 30
+    (emit-return-pc label)
+    (note-this-location vop :non-local-entry)
+
+    ;; Copy args.
+    (load-stack-tn dst top)
+    (move start src)
+    (move count num)
+
+    ;; Establish results.
+    (sc-case new-start
+      (any-reg (move dst new-start))
+      (control-stack (store-stack-tn dst new-start)))
+    (inst comb := num zero-tn done)
+    (sc-case new-count
+      (any-reg (inst move num new-count))
+      (control-stack (store-stack-tn num new-count)))
+    ;; Load the first word.
+    (inst ldwm word-bytes src temp)
+
+    ;; Copy stuff on stack.
+    LOOP
+    (inst stwm temp word-bytes dst)
+    (inst addib :<> (fixnum -1) num loop :nullify t)
+    (inst ldwm word-bytes src temp)
+
+    DONE
+    (inst move dst csp-tn)))
+
+
+;;; This VOP is just to force the TNs used in the cleanup onto the stack.
+;;;
+(define-vop (uwp-entry)
+  (:info label)
+  (:save-p :force-to-stack)
+  (:results (block) (start) (count))
+  (:ignore block start count)
+  (:vop-var vop)
+  (:generator 0
+    (emit-return-pc label)
+    (note-this-location vop :non-local-entry)))
diff --git a/compiler/hppa/parms.lisp b/compiler/hppa/parms.lisp
new file mode 100644
index 000000000..32111708f
--- /dev/null
+++ b/compiler/hppa/parms.lisp
@@ -0,0 +1,216 @@
+;;; -*- Package: hppa -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/parms.lisp,v 1.1 1992/07/13 03:48:29 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains some parameterizations of various VM
+;;; attributes for the HP-PA.  This file is separate from other stuff so 
+;;; that it can be compiled and loaded earlier. 
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package :hppa)
+(use-package :c)
+
+
+;;;; Compiler constants.
+
+(eval-when (compile eval load)
+
+(setf (backend-name *target-backend*) "HPPA")
+(setf (backend-version *target-backend*) "HP-PA 1.1")
+(setf (backend-fasl-file-type *target-backend*) "hpf")
+(setf (backend-fasl-file-implementation *target-backend*)
+      hppa-fasl-file-implementation)
+(setf (backend-fasl-file-version *target-backend*) 1)
+(setf (backend-register-save-penalty *target-backend*) 3)
+(setf (backend-byte-order *target-backend*) :big-endian)
+(setf (backend-page-size *target-backend*) 4096)
+
+); eval-when
+
+
+;;;; Machine Architecture parameters:
+
+(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
+
+	  single-float-bias single-float-exponent-byte
+	  single-float-significand-byte single-float-normal-exponent-min
+	  single-float-normal-exponent-max single-float-hidden-bit
+	  single-float-trapping-nan-bit single-float-digits
+
+	  double-float-bias double-float-exponent-byte
+	  double-float-significand-byte double-float-normal-exponent-min
+	  double-float-normal-exponent-max double-float-hidden-bit
+	  double-float-trapping-nan-bit double-float-digits
+
+	  float-underflow-trap-bit float-overflow-trap-bit
+	  float-imprecise-trap-bit float-invalid-trap-bit
+	  float-divide-by-zero-trap-bit))
+
+	  
+
+(eval-when (compile load eval)
+
+(defconstant word-bits 32
+  "Number of bits per word where a word holds one lisp descriptor.")
+
+(defconstant byte-bits 8
+  "Number of bits per byte where a byte is the smallest addressable object.")
+
+(defconstant word-shift (1- (integer-length (/ word-bits byte-bits)))
+  "Number of bits to shift between word addresses and byte addresses.")
+
+(defconstant word-bytes (/ word-bits byte-bits)
+  "Number of bytes in a word.")
+
+(defconstant float-sign-shift 31)
+
+(defconstant single-float-bias 126)
+(defconstant single-float-exponent-byte (byte 8 23))
+(defconstant single-float-significand-byte (byte 23 0))
+(defconstant single-float-normal-exponent-min 1)
+(defconstant single-float-normal-exponent-max 254)
+(defconstant single-float-hidden-bit (ash 1 23))
+(defconstant single-float-trapping-nan-bit (ash 1 22))
+
+(defconstant double-float-bias 1022)
+(defconstant double-float-exponent-byte (byte 11 20))
+(defconstant double-float-significand-byte (byte 20 0))
+(defconstant double-float-normal-exponent-min 1)
+(defconstant double-float-normal-exponent-max #x7FE)
+(defconstant double-float-hidden-bit (ash 1 20))
+(defconstant double-float-trapping-nan-bit (ash 1 19))
+
+(defconstant single-float-digits
+  (+ (byte-size single-float-significand-byte) 1))
+
+(defconstant double-float-digits
+  (+ (byte-size double-float-significand-byte) word-bits 1))
+
+(defconstant float-inexact-trap-bit (ash 1 0))
+(defconstant float-underflow-trap-bit (ash 1 1))
+(defconstant float-overflow-trap-bit (ash 1 2))
+(defconstant float-divide-by-zero-trap-bit (ash 1 3))
+(defconstant float-invalid-trap-bit (ash 1 4))
+
+(defconstant float-round-to-nearest 0)
+(defconstant float-round-to-zero 1)
+(defconstant float-round-to-positive 2)
+(defconstant float-round-to-negative 3)
+
+(defconstant float-rounding-mode (byte 2 7))
+(defconstant float-sticky-bits (byte 5 27))
+(defconstant float-traps-byte (byte 5 0))
+(defconstant float-exceptions-byte (byte 5 27))
+(defconstant float-condition-bit (ash 1 26))
+(defconstant float-fast-bit 0)			  ; No fast mode on HPPA.
+
+); eval-when
+
+
+
+;;;; Description of the target address space.
+
+(export '(target-read-only-space-start
+	  target-static-space-start
+	  target-dynamic-space-start))
+
+;;; Where to put the different spaces.
+;;; 
+(defparameter target-read-only-space-start #x20000000)
+(defparameter target-static-space-start    #x28000000)
+(defparameter target-dynamic-space-start   #x30000000)
+
+;; The space-register holding the lisp heap.
+(defconstant lisp-heap-space 4)
+
+;; The space-register holding the C text segment.
+(defconstant c-text-space 4)
+
+
+;;;; Other random constants.
+
+(export '(halt-trap pending-interrupt-trap error-trap cerror-trap
+	  breakpoint-trap function-end-breakpoint-trap single-step-breakpoint
+	  trace-table-normal trace-table-call-site
+	  trace-table-function-prologue trace-table-function-epilogue))
+
+(defenum (:suffix -trap :start 8)
+  halt
+  pending-interrupt
+  error
+  cerror
+  breakpoint
+  function-end-breakpoint
+  single-step-breakpoint)
+
+(defenum (:prefix trace-table-)
+  normal
+  call-site
+  function-prologue
+  function-epilogue)
+
+
+
+;;;; Static symbols.
+
+(export '(static-symbols static-functions))
+
+;;; These symbols are loaded into static space directly after NIL so
+;;; that the system can compute their address by adding a constant
+;;; amount to NIL.
+;;;
+;;; The fdefn objects for the static functions are loaded into static
+;;; space directly after the static symbols.  That way, the raw-addr
+;;; can be loaded directly out of them by indirecting relative to NIL.
+;;;
+(defparameter static-symbols
+  '(t
+
+    ;; The C startup code must fill these in.
+    lisp::lisp-environment-list
+    lisp::lisp-command-line-list
+    lisp::*initial-fdefn-objects*
+
+    ;; Functions that the C code needs to call
+    lisp::%initial-function
+    lisp::maybe-gc
+    kernel::internal-error
+    di::handle-breakpoint
+    lisp::fdefinition-object
+
+    ;; Free Pointers.
+    lisp::*read-only-space-free-pointer*
+    lisp::*static-space-free-pointer*
+    lisp::*initial-dynamic-space-free-pointer*
+    lisp::*allocation-pointer*
+
+    ;; The binding stack.
+    lisp::*binding-stack-pointer*
+
+    ;; Things needed for non-local-exit.
+    lisp::*current-catch-block*
+    lisp::*current-unwind-protect-block*
+    *eval-stack-top*
+
+    ;; Interrupt Handling
+    lisp::*free-interrupt-context-index*
+    unix::*interrupts-enabled*
+    unix::*interrupt-pending*
+    ))
+
+(defparameter static-functions
+  '(length
+    two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql
+    %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm
+    ))
diff --git a/compiler/hppa/pred.lisp b/compiler/hppa/pred.lisp
new file mode 100644
index 000000000..8c87d7eeb
--- /dev/null
+++ b/compiler/hppa/pred.lisp
@@ -0,0 +1,43 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/pred.lisp,v 1.1 1992/07/13 03:48:30 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of predicate VOPs for the HPPA
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "HPPA")
+
+
+;;;; The Branch VOP.
+
+;;; The unconditional branch, emitted when we can't drop through to the desired
+;;; destination.  Dest is the continuation we transfer control to.
+;;;
+(define-vop (branch)
+  (:info dest)
+  (:generator 5
+    (inst b dest :nullify t)))
+
+
+;;;; Conditional VOPs:
+
+(define-vop (if-eq)
+  (:args (x :scs (any-reg descriptor-reg zero null))
+	 (y :scs (any-reg descriptor-reg zero null)))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:translate eq)
+  (:generator 3
+    (inst bc := not-p x y target)))
diff --git a/compiler/hppa/print.lisp b/compiler/hppa/print.lisp
new file mode 100644
index 000000000..1701c8c59
--- /dev/null
+++ b/compiler/hppa/print.lisp
@@ -0,0 +1,48 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/print.lisp,v 1.1 1992/07/13 03:48:31 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains temporary printing utilities and similar noise.
+;;;
+;;; Written by William Lott.
+
+(in-package "HPPA")
+
+
+(define-vop (print)
+  (:args (object :scs (descriptor-reg) :target arg))
+  (:results (result :scs (descriptor-reg)))
+  (:save-p t)
+  (:temporary (:sc non-descriptor-reg :offset cfunc-offset) cfunc)
+  (:temporary (:sc non-descriptor-reg :offset nl0-offset :from (:argument 0))
+	      arg)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset :to (:result 0))
+	      res)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:vop-var vop)
+  (:generator 0
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (move object arg)
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      ;; Allocate 64 bytes, the minimum stack size.
+      (inst addi 64 nsp-tn nsp-tn)
+      (inst li (make-fixup "debug_print" :foreign) cfunc)
+      (let ((fixup (make-fixup "call_into_c" :foreign)))
+	(inst ldil fixup temp)
+	(inst ble fixup c-text-space temp :nullify t)
+	(inst nop))
+      (inst addi -64 nsp-tn nsp-tn)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save))
+      (move res result))))
diff --git a/compiler/hppa/sap.lisp b/compiler/hppa/sap.lisp
new file mode 100644
index 000000000..07458041a
--- /dev/null
+++ b/compiler/hppa/sap.lisp
@@ -0,0 +1,286 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/sap.lisp,v 1.1 1992/07/13 03:48:33 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the HP-PA VM definition of SAP operations.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "HPPA")
+
+
+;;;; Moves and coercions:
+
+;;; Move a tagged SAP to an untagged representation.
+;;;
+(define-vop (move-to-sap)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:results (y :scs (sap-reg)))
+  (:note "system area pointer indirection")
+  (:generator 1
+    (loadw y x sap-pointer-slot other-pointer-type)))
+
+;;;
+(define-move-vop move-to-sap :move
+  (descriptor-reg) (sap-reg))
+
+
+;;; Move an untagged SAP to a tagged representation.
+;;;
+(define-vop (move-from-sap)
+  (:args (x :scs (sap-reg) :to (:eval 1)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:results (y :scs (descriptor-reg) :from (:eval 0)))
+  (:note "system area pointer allocation")
+  (:generator 20
+    (with-fixed-allocation (y ndescr sap-type sap-size)
+      (storew x y sap-pointer-slot other-pointer-type))))
+;;;
+(define-move-vop move-from-sap :move
+  (sap-reg) (descriptor-reg))
+
+
+;;; Move untagged sap values.
+;;;
+(define-vop (sap-move)
+  (:args (x :target y
+	    :scs (sap-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (sap-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move x y)))
+;;;
+(define-move-vop sap-move :move
+  (sap-reg) (sap-reg))
+
+
+;;; Move untagged sap arguments/return-values.
+;;;
+(define-vop (move-sap-argument)
+  (:args (x :target y
+	    :scs (sap-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      (sap-reg
+       (move x y))
+      (sap-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-sap-argument :move-argument
+  (descriptor-reg sap-reg) (sap-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (sap-reg) (descriptor-reg))
+
+
+
+;;;; SAP-INT and INT-SAP
+
+(define-vop (sap-int)
+  (:args (sap :scs (sap-reg) :target int))
+  (:arg-types system-area-pointer)
+  (:results (int :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate sap-int)
+  (:policy :fast-safe)
+  (:generator 1
+    (move sap int)))
+
+(define-vop (int-sap)
+  (:args (int :scs (unsigned-reg) :target sap))
+  (:arg-types unsigned-num)
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate int-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move int sap)))
+
+
+
+;;;; POINTER+ and POINTER-
+
+(define-vop (pointer+)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg) :target res)
+	 (offset :scs (signed-reg)))
+  (:arg-types system-area-pointer signed-num)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (inst add ptr offset res)))
+
+(define-vop (pointer+-c)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg)))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 11)))
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (inst addi offset ptr res)))
+
+(define-vop (pointer-)
+  (:translate sap-)
+  (:args (ptr1 :scs (sap-reg))
+	 (ptr2 :scs (sap-reg)))
+  (:arg-types system-area-pointer system-area-pointer)
+  (:policy :fast-safe)
+  (:results (res :scs (signed-reg)))
+  (:result-types signed-num)
+  (:generator 1
+    (inst sub ptr1 ptr2 res)))
+
+
+
+;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
+
+(eval-when (compile eval)
+
+(defmacro def-system-ref-and-set
+	  (ref-name set-name sc type size &optional signed)
+  (let ((ref-name-c (symbolicate ref-name "-C"))
+	(set-name-c (symbolicate set-name "-C")))
+    `(progn
+       (define-vop (,ref-name)
+	 (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (object :scs (sap-reg))
+		(offset :scs (unsigned-reg)))
+	 (:arg-types system-area-pointer unsigned-num)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	   (inst ,(ecase size
+		    (:byte 'ldbx)
+		    (:short 'ldhx)
+		    (:long 'ldwx)
+		    (:float 'fldx))
+		 offset object result)
+	   ,@(when (and signed (not (eq size :long)))
+	       `((inst extrs result 31 ,(ecase size
+			  (:byte 8)
+			  (:short 16))
+		       result)))))
+       (define-vop (,ref-name-c)
+	 (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (object :scs (sap-reg)))
+	 (:arg-types system-area-pointer
+		     (:constant ,(if (eq size :float)
+				     '(signed-byte 5)
+				     '(signed-byte 14))))
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	   (inst ,(ecase size
+		    (:byte 'ldb)
+		    (:short 'ldh)
+		    (:long 'ldw)
+		    (:float 'flds))
+		 offset object result)
+	   ,@(when (and signed (not (eq size :long)))
+	       `((inst extrs result 31 ,(ecase size
+			  (:byte 8)
+			  (:short 16))
+		       result)))))
+       (define-vop (,set-name)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (object :scs (sap-reg)
+			,@(unless (eq size :float) '(:target sap)))
+		(offset :scs (unsigned-reg))
+		(value :scs (,sc) :target result))
+	 (:arg-types system-area-pointer unsigned-num ,type)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 ,@(unless (eq size :float)
+	     '((:temporary (:scs (sap-reg) :from (:argument 0)) sap)))
+	 (:generator 5
+	   ,@(if (eq size :float)
+		 `((inst fstx value offset object)
+		   (unless (location= value result)
+		     (inst funop :copy value result)))
+		 `((inst add object offset sap)
+		   (inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
+			 value 0 sap)
+		   (move value result)))))
+       (define-vop (,set-name-c)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (object :scs (sap-reg))
+		(value :scs (,sc) :target result))
+	 (:arg-types system-area-pointer
+		     (:constant ,(if (eq size :float)
+				     '(signed-byte 5)
+				     '(signed-byte 14)))
+		     ,type)
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	   ,@(if (eq size :float)
+		 `((inst fsts value offset object)
+		   (unless (location= value result)
+		     (inst funop :copy value result)))
+		 `((inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
+			 value offset object)
+		   (move value result))))))))
+
+); eval-when (compile eval)
+
+(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
+  unsigned-reg positive-fixnum :byte nil)
+(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
+  signed-reg tagged-num :byte t)
+(def-system-ref-and-set sap-ref-16 %set-sap-ref-16
+  unsigned-reg positive-fixnum :short nil)
+(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
+  signed-reg tagged-num :short t)
+(def-system-ref-and-set sap-ref-32 %set-sap-ref-32
+  unsigned-reg unsigned-num :long nil)
+(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
+  signed-reg signed-num :long t)
+(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
+  sap-reg system-area-pointer :long)
+(def-system-ref-and-set sap-ref-single %set-sap-ref-single
+  single-reg single-float :float)
+(def-system-ref-and-set sap-ref-double %set-sap-ref-double
+  double-reg double-float :float)
+
+
+;;; Noise to convert normal lisp data objects into SAPs.
+
+(define-vop (vector-sap)
+  (:translate vector-sap)
+  (:policy :fast-safe)
+  (:args (vector :scs (descriptor-reg)))
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 2
+    (inst addi
+	  (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type)
+	  vector
+	  sap)))
diff --git a/compiler/hppa/static-fn.lisp b/compiler/hppa/static-fn.lisp
new file mode 100644
index 000000000..0d2d1cc38
--- /dev/null
+++ b/compiler/hppa/static-fn.lisp
@@ -0,0 +1,144 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/static-fn.lisp,v 1.1 1992/07/13 03:48:35 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and macro magic necessary to call static
+;;; functions.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "HPPA")
+
+
+(define-vop (static-function-template)
+  (:save-p t)
+  (:policy :safe)
+  (:variant-vars symbol)
+  (:vop-var vop)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:scs (descriptor-reg)) move-temp)
+  (:temporary (:sc descriptor-reg :offset lra-offset) lra)
+  (:temporary (:scs (interior-reg)) lip)
+  (:temporary (:sc any-reg :offset nargs-offset) nargs)
+  (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
+
+
+(eval-when (compile load eval)
+
+(defun static-function-template-name (num-args num-results)
+  (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
+		  num-args num-results)))
+
+
+(defun moves (src dst)
+  (collect ((moves))
+    (do ((src src (cdr src))
+	 (dst dst (cdr dst)))
+	((or (null src) (null dst)))
+      (moves `(move ,(car src) ,(car dst))))
+    (moves)))
+
+(defun static-function-template-vop (num-args num-results)
+  (assert (and (<= num-args register-arg-count)
+	       (<= num-results register-arg-count))
+	  (num-args num-results)
+	  "Either too many args (~D) or too many results (~D).  Max = ~D"
+	  num-args num-results register-arg-count)
+  (let ((num-temps (max num-args num-results)))
+    (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
+      (dotimes (i num-results)
+	(let ((result-name (intern (format nil "RESULT-~D" i))))
+	  (result-names result-name)
+	  (results `(,result-name :scs (any-reg descriptor-reg)))))
+      (dotimes (i num-temps)
+	(let ((temp-name (intern (format nil "TEMP-~D" i))))
+	  (temp-names temp-name)
+	  (temps `(:temporary (:sc descriptor-reg
+			       :offset ,(nth i register-arg-offsets)
+			       ,@(when (< i num-args)
+				   `(:from (:argument ,i)))
+			       ,@(when (< i num-results)
+				   `(:to (:result ,i)
+				     :target ,(nth i (result-names)))))
+			      ,temp-name))))
+      (dotimes (i num-args)
+	(let ((arg-name (intern (format nil "ARG-~D" i))))
+	  (arg-names arg-name)
+	  (args `(,arg-name
+		  :scs (any-reg descriptor-reg)
+		  :target ,(nth i (temp-names))))))
+      `(define-vop (,(static-function-template-name num-args num-results)
+		    static-function-template)
+	 (:args ,@(args))
+	 ,@(temps)
+	 (:results ,@(results))
+	 (:generator ,(+ 50 num-args num-results)
+	   (let ((lra-label (gen-label))
+		 (cur-nfp (current-nfp-tn vop)))
+	     ,@(moves (arg-names) (temp-names))
+	     (inst li (fixnum ,num-args) nargs)
+	     (inst ldw (static-function-offset symbol) null-tn lip)
+	     (when cur-nfp
+	       (store-stack-tn nfp-save cur-nfp))
+	     (inst move cfp-tn old-fp)
+	     (inst compute-lra-from-code code-tn lra-label temp lra)
+	     (note-this-location vop :call-site)
+	     (inst bv lip)
+	     (inst move csp-tn cfp-tn)
+	     (emit-return-pc lra-label)
+	     ,(collect ((bindings) (links))
+		(do ((temp (temp-names) (cdr temp))
+		     (name 'values (gensym))
+		     (prev nil name)
+		     (i 0 (1+ i)))
+		    ((= i num-results))
+		  (bindings `(,name
+			      (make-tn-ref ,(car temp) nil)))
+		  (when prev
+		    (links `(setf (tn-ref-across ,prev) ,name))))
+		`(let ,(bindings)
+		   ,@(links)
+		   (default-unknown-values vop
+		       ,(if (zerop num-results) nil 'values)
+		       ,num-results move-temp temp lra-label)))
+	     (when cur-nfp
+	       (load-stack-tn cur-nfp nfp-save))
+	     ,@(moves (temp-names) (result-names))))))))
+
+) ; eval-when (compile load eval)
+
+(macrolet
+    ((foo ()
+       (collect ((templates (list 'progn)))
+	 (dotimes (i register-arg-count)
+	   (templates (static-function-template-vop i 1)))
+	 (templates))))
+  (foo))
+
+(defmacro define-static-function (name args &key (results '(x)) translate
+				       policy cost arg-types result-types)
+  `(define-vop (,name
+		,(static-function-template-name (length args)
+						(length results)))
+     (:variant ',name)
+     (:note ,(format nil "static-function ~@(~S~)" name))
+     ,@(when translate
+	 `((:translate ,translate)))
+     ,@(when policy
+	 `((:policy ,policy)))
+     ,@(when cost
+	 `((:generator-cost ,cost)))
+     ,@(when arg-types
+	 `((:arg-types ,@arg-types)))
+     ,@(when result-types
+	 `((:result-types ,@result-types)))))
diff --git a/compiler/hppa/subprim.lisp b/compiler/hppa/subprim.lisp
new file mode 100644
index 000000000..09379f233
--- /dev/null
+++ b/compiler/hppa/subprim.lisp
@@ -0,0 +1,58 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/subprim.lisp,v 1.1 1992/07/13 03:48:35 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    Linkage information for standard static functions, and random vops.
+;;;
+;;; Written by William Lott.
+;;; 
+(in-package "HPPA")
+
+
+
+;;;; Length
+
+(define-vop (length/list)
+  (:translate length)
+  (:args (object :scs (descriptor-reg) :target ptr))
+  (:arg-types list)
+  (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
+  (:temporary (:scs (non-descriptor-reg) :type random) temp)
+  (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
+	      count)
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 50
+    (move object ptr)
+    (inst comb := ptr null-tn done)
+    (inst li 0 count)
+
+    (inst extru ptr 31 3 temp)
+    (inst comib :<> list-pointer-type temp loose :nullify t)
+    (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type)
+
+    LOOP
+    (inst addi (fixnum 1) count count)
+    (inst comb := ptr null-tn done :nullify t)
+    (inst extru ptr 31 3 temp)
+    (inst comib := list-pointer-type temp loop :nullify t)
+    (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type)
+
+    LOOSE
+    (cerror-call vop done object-not-list-error ptr)
+
+    DONE
+    (move count result)))
+
+(define-static-function length (object) :translate length)
diff --git a/compiler/hppa/system.lisp b/compiler/hppa/system.lisp
new file mode 100644
index 000000000..1f3fb929e
--- /dev/null
+++ b/compiler/hppa/system.lisp
@@ -0,0 +1,230 @@
+;;; -*- Package: hppa -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/system.lisp,v 1.1 1992/07/13 03:48:36 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; HPPA VM definitions of various system hacking operations.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "HPPA")
+
+
+;;;; Type frobbing VOPs
+
+(define-vop (get-lowtag)
+  (:translate get-lowtag)
+  (:policy :fast-safe)
+  (:args (object :scs (any-reg descriptor-reg) :target result))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+    (inst extru object 31 3 result)))
+
+(define-vop (get-type)
+  (:translate get-type)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 1)))
+  (:results (result :scs (unsigned-reg) :from (:eval 0)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (inst extru object 31 3 result)
+    (inst comib := other-pointer-type result other-ptr :nullify t)
+    (inst comib := function-pointer-type result function-ptr :nullify t)
+    (inst bb t object 31 done :nullify t)
+    (inst extru object 31 2 result :<>)
+    (inst extru object 31 8 result)
+    (inst nop :tr)
+
+    FUNCTION-PTR
+    (load-type result object (- function-pointer-type))
+    (inst nop :tr)
+    
+    OTHER-PTR
+    (load-type result object (- other-pointer-type))
+    
+    DONE))
+
+(define-vop (function-subtype)
+  (:translate function-subtype)
+  (:policy :fast-safe)
+  (:args (function :scs (descriptor-reg)))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (load-type result function (- function-pointer-type))))
+
+(define-vop (set-function-subtype)
+  (:translate (setf function-subtype))
+  (:policy :fast-safe)
+  (:args (type :scs (unsigned-reg) :target result)
+	 (function :scs (descriptor-reg)))
+  (:arg-types positive-fixnum *)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (inst stb type (- 3 function-pointer-type) function)
+    (move type result)))
+
+(define-vop (get-header-data)
+  (:translate get-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (loadw res x 0 other-pointer-type)
+    (inst srl res 8 res)))
+
+(define-vop (get-closure-length)
+  (:translate get-closure-length)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (loadw res x 0 function-pointer-type)
+    (inst srl res 8 res)))
+
+(define-vop (set-header-data)
+  (:translate set-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg) :target res)
+	 (data :scs (unsigned-reg)))
+  (:arg-types * positive-fixnum)
+  (:results (res :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 6
+    (loadw temp x 0 vm:other-pointer-type)
+    (inst dep data 23 24 temp)
+    (storew temp x 0 vm:other-pointer-type)
+    (move x res)))
+
+(define-vop (set-header-data-c)
+  (:translate set-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg) :target res))
+  (:arg-types * (:constant (signed-byte 5)))
+  (:info data)
+  (:results (res :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 5
+    (loadw temp x 0 vm:other-pointer-type)
+    (inst dep data 23 24 temp)
+    (storew temp x 0 vm:other-pointer-type)
+    (move x res)))
+
+(define-vop (c::make-fixnum)
+  (:args (ptr :scs (any-reg descriptor-reg)))
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    ;;
+    ;; Some code (the hash table code) depends on this returning a
+    ;; positive number so make sure it does.
+    (inst zdep ptr 29 29 res)))
+
+(define-vop (c::make-other-immediate-type)
+  (:args (val :scs (any-reg descriptor-reg))
+	 (type :scs (any-reg descriptor-reg) :target temp))
+  (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 2
+    (inst sll val (- type-bits 2) res)
+    (inst sra type 2 temp)
+    (inst or res temp res)))
+
+
+;;;; Allocation
+
+(define-vop (dynamic-space-free-pointer)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate dynamic-space-free-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (move alloc-tn int)))
+
+(define-vop (binding-stack-pointer-sap)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate binding-stack-pointer-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move bsp-tn int)))
+
+(define-vop (control-stack-pointer-sap)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate control-stack-pointer-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move csp-tn int)))
+
+
+;;;; Code object frobbing.
+
+(define-vop (code-instructions)
+  (:translate code-instructions)
+  (:policy :fast-safe)
+  (:args (code :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 10
+    (loadw ndescr code 0 other-pointer-type)
+    (inst srl ndescr 8 ndescr)
+    (inst sll ndescr 2 ndescr)
+    (inst addi (- other-pointer-type) ndescr ndescr)
+    (inst add code ndescr sap)))
+
+(define-vop (compute-function)
+  (:args (code :scs (descriptor-reg))
+	 (offset :scs (signed-reg unsigned-reg)))
+  (:arg-types * positive-fixnum)
+  (:results (func :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:generator 10
+    (loadw ndescr code 0 vm:other-pointer-type)
+    (inst srl ndescr 8 ndescr)
+    (inst sll ndescr 2 ndescr)
+    (inst add ndescr offset ndescr)
+    (inst addi (- function-pointer-type other-pointer-type) ndescr ndescr)
+    (inst add ndescr code func)))
+
+
+;;;; Other random VOPs.
+
+
+(defknown unix::do-pending-interrupt () (values))
+(define-vop (unix::do-pending-interrupt)
+  (:policy :fast-safe)
+  (:translate unix::do-pending-interrupt)
+  (:generator 1
+    (inst break pending-interrupt-trap)))
+
+
+(define-vop (halt)
+  (:generator 1
+    (inst break halt-trap)))
+
+
+;;;; Dynamic vop count collection support
+
+(define-vop (count-me)
+  (:args (count-vector :scs (descriptor-reg)))
+  (:info index)
+  (:temporary (:scs (non-descriptor-reg)) count)
+  (:generator 1
+    (let ((offset
+	   (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
+      (inst ldw offset count-vector count)
+      (inst addi 1 count count)
+      (inst stw count offset count-vector))))
diff --git a/compiler/hppa/type-vops.lisp b/compiler/hppa/type-vops.lisp
new file mode 100644
index 000000000..9e33c2cee
--- /dev/null
+++ b/compiler/hppa/type-vops.lisp
@@ -0,0 +1,492 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/type-vops.lisp,v 1.1 1992/07/13 03:48:37 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;; 
+;;; This file contains the VM definition of type testing and checking VOPs
+;;; for the HPPA
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "HPPA")
+
+
+
+;;;; Test generation utilities.
+
+(eval-when (compile eval)
+
+(defparameter immediate-types
+  (list unbound-marker-type base-char-type))
+
+(defparameter function-header-types
+  (list funcallable-instance-header-type closure-header-type
+	byte-code-function-type byte-code-closure-type
+	function-header-type closure-function-header-type))
+
+(defun canonicalize-headers (headers)
+  (collect ((results))
+    (let ((start nil)
+	  (prev nil)
+	  (delta (- other-immediate-1-type other-immediate-0-type)))
+      (flet ((emit-test ()
+	       (results (if (= start prev)
+			    start
+			    (cons start prev)))))
+	(dolist (header (sort headers #'<))
+	  (cond ((null start)
+		 (setf start header)
+		 (setf prev header))
+		((= header (+ prev delta))
+		 (setf prev header))
+		(t
+		 (emit-test)
+		 (setf start header)
+		 (setf prev header))))
+	(emit-test)))
+    (results)))
+
+(defmacro test-type (value temp target not-p &rest type-codes)
+  ;; Determine what interesting combinations we need to test for.
+  (let* ((type-codes (mapcar #'eval type-codes))
+	 (fixnump (and (member even-fixnum-type type-codes)
+		       (member odd-fixnum-type type-codes)
+		       t))
+	 (lowtags (remove lowtag-limit type-codes :test #'<))
+	 (extended (remove lowtag-limit type-codes :test #'>))
+	 (immediates (intersection extended immediate-types :test #'eql))
+	 (headers (set-difference extended immediate-types :test #'eql))
+	 (function-p (if (intersection headers function-header-types)
+			 (if (subsetp headers function-header-types)
+			     t
+			     (error "Can't test for mix of function subtypes ~
+				     and normal header types."))
+			 nil)))
+    (unless type-codes
+      (error "Must supply at least on type for test-type."))
+    (cond
+     (fixnump
+      (when (remove-if #'(lambda (x)
+			   (or (= x even-fixnum-type)
+			       (= x odd-fixnum-type)))
+		       lowtags)
+	(error "Can't mix fixnum testing with other lowtags."))
+      (when function-p
+	(error "Can't mix fixnum testing with function subtype testing."))
+      (when immediates
+	(error "Can't mix fixnum testing with other immediates."))
+      (if headers
+	  `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
+				     ',(canonicalize-headers headers))
+	  `(%test-fixnum ,value ,temp ,target ,not-p)))
+     (immediates
+      (when headers
+	(error "Can't mix testing of immediates with testing of headers."))
+      (when lowtags
+	(error "Can't mix testing of immediates with testing of lowtags."))
+      (when (cdr immediates)
+	(error "Can't test multiple immediates at the same time."))
+      `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
+     (lowtags
+      (when (cdr lowtags)
+	(error "Can't test multiple lowtags at the same time."))
+      (if headers
+	  `(%test-lowtag-and-headers
+	    ,value ,temp ,target ,not-p ,(car lowtags)
+	    ,function-p ',(canonicalize-headers headers))
+	  `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
+     (headers
+      `(%test-headers ,value ,temp ,target ,not-p ,function-p
+		      ',(canonicalize-headers headers)))
+     (t
+      (error "Nothing to test?")))))
+
+); eval-when (compile eval)
+
+(defun %test-fixnum (value temp target not-p)
+  (declare (ignore temp))
+  (assemble ()
+    (inst extru value 31 2 zero-tn (if not-p := :<>))
+    (inst b target :nullify t)))
+
+(defun %test-fixnum-and-headers (value temp target not-p headers)
+  (let ((drop-through (gen-label)))
+    (assemble ()
+      (inst extru value 31 2 zero-tn :<>)
+      (inst b (if not-p drop-through target) :nullify t))
+    (%test-headers value temp target not-p nil headers drop-through)))
+
+(defun %test-immediate (value temp target not-p immediate)
+  (assemble ()
+    (inst extru value 31 8 temp)
+    (inst bci := not-p immediate temp target)))
+
+(defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded)
+  (assemble ()
+    (unless temp-loaded
+      (inst extru value 31 3 temp))
+    (inst bci := not-p lowtag temp target)))
+
+(defun %test-lowtag-and-headers (value temp target not-p lowtag
+				       function-p headers)
+  (let ((drop-through (gen-label)))
+    (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
+    (%test-headers value temp target not-p function-p headers drop-through t)))
+
+(defun %test-headers (value temp target not-p function-p headers
+			    &optional (drop-through (gen-label)) temp-loaded)
+  (let ((lowtag (if function-p function-header-type other-pointer-type)))
+    (multiple-value-bind
+	(equal greater-or-equal when-true when-false)
+	;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to
+	;; TARGET.  WHEN-TRUE and WHEN-FALSE are the labels to branch to when
+	;; we know it's true and when we know it's false respectively.
+	(if not-p
+	    (values :<> :< drop-through target)
+	    (values := :>= target drop-through))
+      (assemble ()
+	(%test-lowtag value temp when-false t lowtag temp-loaded)
+	(inst ldb (- 3 lowtag) value temp)
+	(do ((remaining headers (cdr remaining)))
+	    ((null remaining))
+	  (let ((header (car remaining))
+		(last (null (cdr remaining))))
+	    (cond
+	     ((atom header)
+	      (if last
+		  (inst bci equal nil header temp target)
+		  (inst bci := nil header temp when-true)))
+	     (t
+	      (let ((start (car header))
+		    (end (cdr header)))
+		(unless (= start bignum-type)
+		  (inst bci :> nil start temp when-false))
+		(if last
+		    (inst bci greater-or-equal nil end temp target)
+		    (inst bci :>= nil end temp when-true)))))))
+	(emit-label drop-through)))))
+
+
+;;;; Type checking and testing:
+
+(define-vop (check-type)
+  (:args (value :target result :scs (any-reg descriptor-reg)))
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(define-vop (type-predicate)
+  (:args (value :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe))
+
+(eval-when (compile eval)
+
+(defun cost-to-test-types (type-codes)
+  (+ (* 2 (length type-codes))
+     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
+
+(defmacro def-type-vops (pred-name check-name ptype error-code
+				   &rest type-codes)
+  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
+    `(progn
+       ,@(when pred-name
+	   `((define-vop (,pred-name type-predicate)
+	       (:translate ,pred-name)
+	       (:generator ,cost
+		 (test-type value temp target not-p ,@type-codes)))))
+       ,@(when check-name
+	   `((define-vop (,check-name check-type)
+	       (:generator ,cost
+		 (let ((err-lab
+			(generate-error-code vop ,error-code value)))
+		   (test-type value temp err-lab t ,@type-codes)
+		   (move value result))))))
+       ,@(when ptype
+	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+); eval-when (compile eval)
+
+(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
+  even-fixnum-type odd-fixnum-type)
+
+(def-type-vops functionp check-function function
+  object-not-function-error function-pointer-type)
+
+(def-type-vops listp check-list list object-not-list-error
+  list-pointer-type)
+
+(def-type-vops structurep check-structure structure object-not-structure-error
+  structure-pointer-type)
+
+(def-type-vops bignump check-bigunm bignum
+  object-not-bignum-error bignum-type)
+
+(def-type-vops ratiop check-ratio ratio
+  object-not-ratio-error ratio-type)
+
+(def-type-vops complexp check-complex complex
+  object-not-complex-error complex-type)
+
+(def-type-vops single-float-p check-single-float single-float
+  object-not-single-float-error single-float-type)
+
+(def-type-vops double-float-p check-double-float double-float
+  object-not-double-float-error double-float-type)
+
+(def-type-vops simple-string-p check-simple-string simple-string
+  object-not-simple-string-error simple-string-type)
+
+(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+  object-not-simple-bit-vector-error simple-bit-vector-type)
+
+(def-type-vops simple-vector-p check-simple-vector simple-vector
+  object-not-simple-vector-error simple-vector-type)
+
+(def-type-vops simple-array-unsigned-byte-2-p
+  check-simple-array-unsigned-byte-2
+  simple-array-unsigned-byte-2
+  object-not-simple-array-unsigned-byte-2-error
+  simple-array-unsigned-byte-2-type)
+
+(def-type-vops simple-array-unsigned-byte-4-p
+  check-simple-array-unsigned-byte-4
+  simple-array-unsigned-byte-4
+  object-not-simple-array-unsigned-byte-4-error
+  simple-array-unsigned-byte-4-type)
+
+(def-type-vops simple-array-unsigned-byte-8-p
+  check-simple-array-unsigned-byte-8
+  simple-array-unsigned-byte-8
+  object-not-simple-array-unsigned-byte-8-error
+  simple-array-unsigned-byte-8-type)
+
+(def-type-vops simple-array-unsigned-byte-16-p
+  check-simple-array-unsigned-byte-16
+  simple-array-unsigned-byte-16
+  object-not-simple-array-unsigned-byte-16-error
+  simple-array-unsigned-byte-16-type)
+
+(def-type-vops simple-array-unsigned-byte-32-p
+  check-simple-array-unsigned-byte-32
+  simple-array-unsigned-byte-32
+  object-not-simple-array-unsigned-byte-32-error
+  simple-array-unsigned-byte-32-type)
+
+(def-type-vops simple-array-single-float-p check-simple-array-single-float
+  simple-array-single-float object-not-simple-array-single-float-error
+  simple-array-single-float-type)
+
+(def-type-vops simple-array-double-float-p check-simple-array-double-float
+  simple-array-double-float object-not-simple-array-double-float-error
+  simple-array-double-float-type)
+
+(def-type-vops base-char-p check-base-char base-char
+  object-not-base-char-error base-char-type)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+  system-area-pointer object-not-sap-error sap-type)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+  object-not-weak-pointer-error weak-pointer-type)
+
+(def-type-vops scavenger-hook-p nil nil nil
+  0)
+
+(def-type-vops code-component-p nil nil nil
+  code-header-type)
+
+(def-type-vops lra-p nil nil nil
+  return-pc-header-type)
+
+(def-type-vops fdefn-p nil nil nil
+  fdefn-type)
+
+(def-type-vops funcallable-instance-p nil nil nil
+  funcallable-instance-header-type)
+
+(def-type-vops array-header-p nil nil nil
+  simple-array-type complex-string-type complex-bit-vector-type
+  complex-vector-type complex-array-type)
+
+(def-type-vops nil check-function-or-symbol nil
+  object-not-function-or-symbol-error
+  function-pointer-type symbol-header-type)
+
+(def-type-vops stringp check-string nil object-not-string-error
+  simple-string-type complex-string-type)
+
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+  simple-bit-vector-type complex-bit-vector-type)
+
+(def-type-vops vectorp check-vector nil object-not-vector-error
+  simple-string-type simple-bit-vector-type simple-vector-type
+  simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
+  simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
+  simple-array-unsigned-byte-32-type simple-array-single-float-type
+  simple-array-double-float-type complex-string-type
+  complex-bit-vector-type complex-vector-type)
+
+(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
+  simple-array-type simple-string-type simple-bit-vector-type
+  simple-vector-type simple-array-unsigned-byte-2-type
+  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type)
+
+(def-type-vops arrayp check-array nil object-not-array-error
+  simple-array-type simple-string-type simple-bit-vector-type
+  simple-vector-type simple-array-unsigned-byte-2-type
+  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type
+  complex-string-type complex-bit-vector-type complex-vector-type
+  complex-array-type)
+
+(def-type-vops numberp check-number nil object-not-number-error
+  even-fixnum-type odd-fixnum-type bignum-type ratio-type
+  single-float-type double-float-type complex-type)
+
+(def-type-vops rationalp check-rational nil object-not-rational-error
+  even-fixnum-type odd-fixnum-type ratio-type bignum-type)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+  even-fixnum-type odd-fixnum-type bignum-type)
+
+(def-type-vops floatp check-float nil object-not-float-error
+  single-float-type double-float-type)
+
+(def-type-vops realp check-real nil object-not-real-error
+  even-fixnum-type odd-fixnum-type ratio-type bignum-type
+  single-float-type double-float-type)
+
+
+;;;; Other integer ranges.
+
+;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+
+(defun signed-byte-32-test (value temp not-p target not-target)
+  (multiple-value-bind
+      (yep nope)
+      (if not-p
+	  (values not-target target)
+	  (values target not-target))
+    (assemble ()
+      (inst extru value 31 2 zero-tn :<>)
+      (inst b yep :nullify t)
+      (inst extru value 31 3 temp)
+      (inst bci :<> nil other-pointer-type temp nope)
+      (loadw temp value 0 other-pointer-type)
+      (inst bci := not-p (+ (ash 1 type-bits) bignum-type) temp target)))
+  (undefined-value))
+
+(define-vop (signed-byte-32-p type-predicate)
+  (:translate signed-byte-32-p)
+  (:generator 45
+    (signed-byte-32-test value temp not-p target not-target)
+    NOT-TARGET))
+
+(define-vop (check-signed-byte-32 check-type)
+  (:generator 45
+    (let ((loose (generate-error-code vop object-not-signed-byte-32-error
+				      value)))
+      (signed-byte-32-test value temp t loose okay))
+    OKAY
+    (move value result)))
+
+;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
+;;; bignum with exactly one positive digit, or a bignum with exactly two digits
+;;; and the second digit all zeros.
+
+(defun unsigned-byte-32-test (value temp not-p target not-target)
+  (let ((nope (if not-p target not-target)))
+    (assemble ()
+      ;; Is it a fixnum?
+      (inst extru value 31 2 zero-tn :<>)
+      (inst b fixnum)
+      (inst move value temp)
+
+      ;; If not, is it an other pointer?
+      (inst extru value 31 3 temp)
+      (inst bci :<> nil other-pointer-type temp nope)
+      ;; Get the header.
+      (loadw temp value 0 other-pointer-type)
+      ;; Is it one?
+      (inst bci := nil (+ (ash 1 type-bits) bignum-type) temp single-word)
+      ;; If it's other than two, we can't be an (unsigned-byte 32)
+      (inst bci :<> nil (+ (ash 2 type-bits) bignum-type) temp nope)
+      ;; Get the second digit.
+      (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
+      ;; All zeros, its an (unsigned-byte 32).
+      (inst comb (if not-p := :<>) temp zero-tn not-target :nullify t)
+      (inst b target :nullify t)
+	
+      SINGLE-WORD
+      ;; Get the single digit.
+      (loadw temp value bignum-digits-offset other-pointer-type)
+
+      ;; positive implies (unsigned-byte 32).
+      FIXNUM
+      (inst bc :>= not-p temp zero-tn target)))
+  (undefined-value))
+
+(define-vop (unsigned-byte-32-p type-predicate)
+  (:translate unsigned-byte-32-p)
+  (:generator 45
+    (unsigned-byte-32-test value temp not-p target not-target)
+    NOT-TARGET))
+
+(define-vop (check-unsigned-byte-32 check-type)
+  (:generator 45
+    (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
+				      value)))
+      (unsigned-byte-32-test value temp t loose okay))
+    OKAY
+    (move value result)))
+
+
+;;;; List/symbol types:
+;;; 
+;;; symbolp (or symbol (eq nil))
+;;; consp (and list (not (eq nil)))
+
+(define-vop (symbolp type-predicate)
+  (:translate symbolp)
+  (:generator 12
+    (inst bc := nil value null-tn (if not-p drop-thru target))
+    (test-type value temp target not-p symbol-header-type)
+    DROP-THRU))
+
+(define-vop (check-symbol check-type)
+  (:generator 12
+    (inst comb := value null-tn drop-thru)
+    (let ((error (generate-error-code vop object-not-symbol-error value)))
+      (test-type value temp error t symbol-header-type))
+    DROP-THRU
+    (move value result)))
+  
+(define-vop (consp type-predicate)
+  (:translate consp)
+  (:generator 8
+    (inst bc := nil value null-tn (if not-p target drop-thru))
+    (test-type value temp target not-p list-pointer-type)
+    DROP-THRU))
+
+(define-vop (check-cons check-type)
+  (:generator 8
+    (let ((error (generate-error-code vop object-not-cons-error value)))
+      (inst bc := nil value null-tn error)
+      (test-type value temp error t list-pointer-type))
+    (move value result)))
diff --git a/compiler/hppa/values.lisp b/compiler/hppa/values.lisp
new file mode 100644
index 000000000..76ff19a08
--- /dev/null
+++ b/compiler/hppa/values.lisp
@@ -0,0 +1,89 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/values.lisp,v 1.1 1992/07/13 03:48:39 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the implementation of unknown-values VOPs.
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "HPPA")
+
+(define-vop (reset-stack-pointer)
+  (:args (ptr :scs (any-reg)))
+  (:generator 1
+    (move ptr csp-tn)))
+
+
+;;; Push some values onto the stack, returning the start and number of values
+;;; pushed as results.  It is assumed that the Vals are wired to the standard
+;;; argument locations.  Nvals is the number of values to push.
+;;;
+;;; The generator cost is pseudo-random.  We could get it right by defining a
+;;; bogus SC that reflects the costs of the memory-to-memory moves for each
+;;; operand, but this seems unworthwhile.
+;;;
+(define-vop (push-values)
+  (:args
+   (vals :more t))
+  (:results (start :scs (any-reg) :from :load)
+	    (count :scs (any-reg)))
+  (:info nvals)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:generator 20
+    (move csp-tn start)
+    (inst addi (* nvals word-bytes) csp-tn csp-tn)
+    (do ((val vals (tn-ref-across val))
+	 (i 0 (1+ i)))
+	((null val))
+      (let ((tn (tn-ref-tn val)))
+	(sc-case tn
+	  (descriptor-reg
+	   (storew tn start i))
+	  (control-stack
+	   (load-stack-tn temp tn)
+	   (storew temp start i)))))
+    (inst li (fixnum nvals) count)))
+
+
+;;; Push a list of values on the stack, returning Start and Count as used in
+;;; unknown values continuations.
+;;;
+(define-vop (values-list)
+  (:args (arg :scs (descriptor-reg) :target list))
+  (:arg-types list)
+  (:policy :fast-safe)
+  (:results (start :scs (any-reg))
+	    (count :scs (any-reg)))
+  (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 0
+    (move arg list)
+    (inst comb := list null-tn done)
+    (move csp-tn start)
+
+    LOOP
+    (loadw temp list cons-car-slot list-pointer-type)
+    (loadw list list cons-cdr-slot list-pointer-type)
+    (inst addi word-bytes csp-tn csp-tn)
+    (storew temp csp-tn -1)
+    (inst extru list 31 lowtag-bits ndescr)
+    (inst comib := list-pointer-type ndescr loop)
+    (inst comb := list null-tn done :nullify t)
+    (error-call vop bogus-argument-to-values-list-error list)
+
+    DONE
+    (inst sub csp-tn start count)))
+
diff --git a/compiler/hppa/vm.lisp b/compiler/hppa/vm.lisp
new file mode 100644
index 000000000..96ceb958c
--- /dev/null
+++ b/compiler/hppa/vm.lisp
@@ -0,0 +1,359 @@
+;;; -*- Package: hppa -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/vm.lisp,v 1.1 1992/07/13 03:48:39 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition for the HP-PA.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "HPPA")
+
+
+;;;; Define the registers
+
+(eval-when (compile eval)
+
+(defmacro defreg (name offset)
+  (let ((offset-sym (symbolicate name "-OFFSET")))
+    `(eval-when (compile eval load)
+       (defconstant ,offset-sym ,offset)
+       (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
+
+(defmacro defregset (name &rest regs)
+  `(eval-when (compile eval load)
+     (defconstant ,name
+       (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
+
+); eval-when (compile eval)
+
+
+(eval-when (compile load eval)
+
+(defvar *register-names* (make-array 32 :initial-element nil))
+
+); eval-when (compile load eval)
+
+
+;; Wired-zero
+(defreg zero 0)
+;; This gets trashed by the C call convention.
+(defreg nfp 1)
+(defreg cfunc 2)
+;; These are the callee saves, so these registers are stay live
+;; over call-out.
+(defreg csp 3)
+(defreg cfp 4)
+(defreg bsp 5)
+(defreg null 6)
+(defreg alloc 7)
+(defreg code 8)
+(defreg fdefn 9)
+(defreg lexenv 10)
+(defreg nargs 11)
+(defreg ocfp 12)
+(defreg lra 13)
+(defreg a0 14)
+(defreg a1 15)
+(defreg a2 16)
+(defreg a3 17)
+(defreg a4 18)
+;; This is where the caller-saves registers start, but we don't really care
+;; because we need to clear the above after call-out to make sure no pointers
+;; into oldspace are kept around.
+(defreg a5 19)
+(defreg l0 20)
+(defreg l1 21)
+(defreg l2 22)
+;; These are the 4 C argument registers.
+(defreg nl3 23)
+(defreg nl2 24)
+(defreg nl1 25)
+(defreg nl0 26)
+;; The global Data Pointer.  We just leave it alone, because we don't need it.
+(defreg dp 27)
+;; These two are use for C return values.
+(defreg nl4 28)
+(defreg nl5 29)
+(defreg nsp 30)
+(defreg lip 31)
+
+(defregset non-descriptor-regs
+  nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc)
+
+(defregset descriptor-regs
+  fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2)
+
+(defregset register-arg-offsets
+  a0 a1 a2 a3 a4 a5)
+
+
+(define-storage-base registers :finite :size 32)
+(define-storage-base float-registers :finite :size 64)
+(define-storage-base control-stack :unbounded :size 8)
+(define-storage-base non-descriptor-stack :unbounded :size 0)
+(define-storage-base constant :non-packed)
+(define-storage-base immediate-constant :non-packed)
+
+;;;
+;;; Handy macro so we don't have to keep changing all the numbers whenever
+;;; we insert a new storage class.
+;;; 
+(defmacro define-storage-classes (&rest classes)
+  (do ((forms (list 'progn)
+	      (let* ((class (car classes))
+		     (sc-name (car class))
+		     (constant-name (intern (concatenate 'simple-string
+							 (string sc-name)
+							 "-SC-NUMBER"))))
+		(list* `(define-storage-class ,sc-name ,index
+			  ,@(cdr class))
+		       `(defconstant ,constant-name ,index)
+		       `(export ',constant-name)
+		       forms)))
+       (index 0 (1+ index))
+       (classes classes (cdr classes)))
+      ((null classes)
+       (nreverse forms))))
+
+(define-storage-classes
+
+  ;; Non-immediate contstants in the constant pool
+  (constant constant)
+
+  ;; ZERO and NULL are in registers.
+  (zero immediate-constant)
+  (null immediate-constant)
+  (fp-single-zero immediate-constant)
+  (fp-double-zero immediate-constant)
+
+  ;; Anything else that can be an immediate.
+  (immediate immediate-constant)
+
+
+  ;; **** The stacks.
+
+  ;; The control stack.  (Scanned by GC)
+  (control-stack control-stack)
+
+  ;; The non-descriptor stacks.
+  (signed-stack non-descriptor-stack) ; (signed-byte 32)
+  (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
+  (base-char-stack non-descriptor-stack) ; non-descriptor characters.
+  (sap-stack non-descriptor-stack) ; System area pointers.
+  (single-stack non-descriptor-stack) ; single-floats
+  (double-stack non-descriptor-stack
+		:element-size 2 :alignment 2) ; double floats.
+
+
+  ;; **** Things that can go in the integer registers.
+
+  ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
+  ;; bad will happen if they are.  (fixnums, characters, header values, etc).
+  (any-reg
+   registers
+   :locations #.(append non-descriptor-regs descriptor-regs)
+   :constant-scs (zero immediate)
+   :save-p t
+   :alternate-scs (control-stack))
+
+  ;; Pointer descriptor objects.  Must be seen by GC.
+  (descriptor-reg registers
+   :locations #.descriptor-regs
+   :constant-scs (constant null immediate)
+   :save-p t
+   :alternate-scs (control-stack))
+
+  ;; Non-Descriptor characters
+  (base-char-reg registers
+   :locations #.non-descriptor-regs
+   :constant-scs (immediate)
+   :save-p t
+   :alternate-scs (base-char-stack))
+
+  ;; Non-Descriptor SAP's (arbitrary pointers into address space)
+  (sap-reg registers
+   :locations #.non-descriptor-regs
+   :constant-scs (immediate)
+   :save-p t
+   :alternate-scs (sap-stack))
+
+  ;; Non-Descriptor (signed or unsigned) numbers.
+  (signed-reg registers
+   :locations #.non-descriptor-regs
+   :constant-scs (zero immediate)
+   :save-p t
+   :alternate-scs (signed-stack))
+  (unsigned-reg registers
+   :locations #.non-descriptor-regs
+   :constant-scs (zero immediate)
+   :save-p t
+   :alternate-scs (unsigned-stack))
+
+  ;; Random objects that must not be seen by GC.  Used only as temporaries.
+  (non-descriptor-reg registers
+   :locations #.non-descriptor-regs)
+
+  ;; Pointers to the interior of objects.  Used only as an temporary.
+  (interior-reg registers
+   :locations (#.lip-offset))
+
+
+  ;; **** Things that can go in the floating point registers.
+
+  ;; Non-Descriptor single-floats.
+  (single-reg float-registers
+   :locations #.(loop for i from 4 to 31 collect i)
+   :constant-scs (fp-single-zero)
+   :save-p t
+   :alternate-scs (single-stack))
+
+  ;; Non-Descriptor double-floats.
+  (double-reg float-registers
+   :locations #.(loop for i from 4 to 31 collect i)
+   :constant-scs (fp-double-zero)
+   :save-p t
+   :alternate-scs (double-stack))
+
+  ;; A catch or unwind block.
+  (catch-block control-stack :element-size vm:catch-block-size))
+
+
+;;;; Make some random tns for important registers.
+
+(eval-when (compile eval)
+
+(defmacro defregtn (name sc)
+  (let ((offset-sym (symbolicate name "-OFFSET"))
+	(tn-sym (symbolicate name "-TN")))
+    `(defparameter ,tn-sym
+       (make-random-tn :kind :normal
+		       :sc (sc-or-lose ',sc)
+		       :offset ,offset-sym))))
+
+); eval-when (compile eval)
+
+;; These, we access by foo-TN only
+
+(defregtn zero any-reg)
+(defregtn null descriptor-reg)
+(defregtn code descriptor-reg)
+(defregtn alloc any-reg)
+(defregtn bsp any-reg)
+(defregtn csp any-reg)
+(defregtn cfp any-reg)
+(defregtn nsp any-reg)
+
+;; These alias regular locations, so we have to make sure we don't bypass
+;; the register allocator when using them.
+(defregtn nargs any-reg)
+(defregtn ocfp any-reg)
+(defregtn lip interior-reg)
+
+;; And some floating point values.
+(defparameter fp-single-zero-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'single-reg)
+		  :offset 0))
+(defparameter fp-double-zero-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'double-reg)
+		  :offset 0))
+
+
+;;; Immediate-Constant-SC  --  Interface
+;;;
+;;; If value can be represented as an immediate constant, then return the
+;;; appropriate SC number, otherwise return NIL.
+;;;
+(def-vm-support-routine immediate-constant-sc (value)
+  (typecase value
+    ((integer 0 0)
+     (sc-number-or-lose 'zero *backend*))
+    (null
+     (sc-number-or-lose 'null *backend*))
+    ((or fixnum system-area-pointer character)
+     (sc-number-or-lose 'immediate *backend*))
+    (symbol
+     (if (static-symbol-p value)
+	 (sc-number-or-lose 'immediate *backend*)
+	 nil))
+    (single-float
+     (if (zerop value)
+	 (sc-number-or-lose 'fp-single-zero)
+	 nil))
+    (double-float
+     (if (zerop value)
+	 (sc-number-or-lose 'fp-double-zero)
+	 nil))))
+
+
+;;;; Function Call Parameters
+
+;;; The SC numbers for register and stack arguments/return values.
+;;;
+(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
+(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
+(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
+
+(eval-when (compile load eval)
+
+;;; Offsets of special stack frame locations
+(defconstant ocfp-save-offset 0)
+(defconstant lra-save-offset 1)
+(defconstant nfp-save-offset 2)
+
+;;; The number of arguments/return values passed in registers.
+;;;
+(defconstant register-arg-count 6)
+
+;;; Names to use for the argument registers.
+;;; 
+(defconstant register-arg-names '(a0 a1 a2 a3 a4 a5))
+
+); Eval-When (Compile Load Eval)
+
+
+;;; A list of TN's describing the register arguments.
+;;;
+(defparameter register-arg-tns
+  (mapcar #'(lambda (n)
+	      (make-random-tn :kind :normal
+			      :sc (sc-or-lose 'descriptor-reg)
+			      :offset n))
+	  register-arg-offsets))
+
+;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
+;;;
+;;; This is used by the debugger.
+;;;
+(export 'single-value-return-byte-offset)
+(defconstant single-value-return-byte-offset 4)
+
+
+;;; LOCATION-PRINT-NAME  --  Interface
+;;;
+;;;    This function is called by debug output routines that want a pretty name
+;;; for a TN's location.  It returns a thing that can be printed with PRINC.
+;;;
+(def-vm-support-routine location-print-name (tn)
+  (declare (type tn tn))
+  (let ((sb (sb-name (sc-sb (tn-sc tn))))
+	(offset (tn-offset tn)))
+    (ecase sb
+      (registers (or (svref *register-names* offset)
+		     (format nil "R~D" offset)))
+      (float-registers (format nil "F~D" offset))
+      (control-stack (format nil "CS~D" offset))
+      (non-descriptor-stack (format nil "NS~D" offset))
+      (constant (format nil "Const~D" offset))
+      (immediate-constant "Immed"))))
-- 
GitLab