From 58aa93ec7b9d142e5b58a4558106aec1510f2c59 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sun, 11 Feb 2001 14:22:08 +0000
Subject: [PATCH] o Compiler backend for the PowerPC contributed by Gary Byers.

---
 assembly/ppc/alloc.lisp           |   21 +
 assembly/ppc/arith.lisp           |  443 +++++++
 assembly/ppc/array.lisp           |  112 ++
 assembly/ppc/assem-rtns.lisp      |  219 +++
 assembly/ppc/support.lisp         |   65 +
 code/exports.lisp                 |   10 +-
 code/ppc-vm.lisp                  |  261 ++++
 compiler/generic/new-genesis.lisp |   23 +-
 compiler/generic/objdef.lisp      |    9 +-
 compiler/generic/vm-macs.lisp     |    6 +-
 compiler/ppc/alloc.lisp           |  201 +++
 compiler/ppc/arith.lisp           |  923 +++++++++++++
 compiler/ppc/array.lisp           |  497 +++++++
 compiler/ppc/c-call.lisp          |  179 +++
 compiler/ppc/call.lisp            | 1269 ++++++++++++++++++
 compiler/ppc/cell.lisp            |  290 ++++
 compiler/ppc/char.lisp            |  147 ++
 compiler/ppc/debug.lisp           |  128 ++
 compiler/ppc/float.lisp           |  505 +++++++
 compiler/ppc/insts.lisp           | 2059 +++++++++++++++++++++++++++++
 compiler/ppc/macros.lisp          |  454 +++++++
 compiler/ppc/memory.lisp          |  118 ++
 compiler/ppc/move.lisp            |  317 +++++
 compiler/ppc/nlx.lisp             |  279 ++++
 compiler/ppc/parms.lisp           |  243 ++++
 compiler/ppc/pred.lisp            |   44 +
 compiler/ppc/print.lisp           |   42 +
 compiler/ppc/sap.lisp             |  290 ++++
 compiler/ppc/static-fn.lisp       |  150 +++
 compiler/ppc/subprim.lisp         |   61 +
 compiler/ppc/system.lisp          |  249 ++++
 compiler/ppc/type-vops.lisp       |  451 +++++++
 compiler/ppc/values.lisp          |  127 ++
 compiler/ppc/vm.lisp              |  334 +++++
 tools/setup.lisp                  |    3 +-
 tools/worldbuild.lisp             |   11 +-
 tools/worldcom.lisp               |   11 +-
 tools/worldload.lisp              |    4 +-
 38 files changed, 10539 insertions(+), 16 deletions(-)
 create mode 100644 assembly/ppc/alloc.lisp
 create mode 100644 assembly/ppc/arith.lisp
 create mode 100644 assembly/ppc/array.lisp
 create mode 100644 assembly/ppc/assem-rtns.lisp
 create mode 100644 assembly/ppc/support.lisp
 create mode 100644 code/ppc-vm.lisp
 create mode 100644 compiler/ppc/alloc.lisp
 create mode 100644 compiler/ppc/arith.lisp
 create mode 100644 compiler/ppc/array.lisp
 create mode 100644 compiler/ppc/c-call.lisp
 create mode 100644 compiler/ppc/call.lisp
 create mode 100644 compiler/ppc/cell.lisp
 create mode 100644 compiler/ppc/char.lisp
 create mode 100644 compiler/ppc/debug.lisp
 create mode 100644 compiler/ppc/float.lisp
 create mode 100644 compiler/ppc/insts.lisp
 create mode 100644 compiler/ppc/macros.lisp
 create mode 100644 compiler/ppc/memory.lisp
 create mode 100644 compiler/ppc/move.lisp
 create mode 100644 compiler/ppc/nlx.lisp
 create mode 100644 compiler/ppc/parms.lisp
 create mode 100644 compiler/ppc/pred.lisp
 create mode 100644 compiler/ppc/print.lisp
 create mode 100644 compiler/ppc/sap.lisp
 create mode 100644 compiler/ppc/static-fn.lisp
 create mode 100644 compiler/ppc/subprim.lisp
 create mode 100644 compiler/ppc/system.lisp
 create mode 100644 compiler/ppc/type-vops.lisp
 create mode 100644 compiler/ppc/values.lisp
 create mode 100644 compiler/ppc/vm.lisp

diff --git a/assembly/ppc/alloc.lisp b/assembly/ppc/alloc.lisp
new file mode 100644
index 000000000..47c9a2cf3
--- /dev/null
+++ b/assembly/ppc/alloc.lisp
@@ -0,0 +1,21 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/alloc.lisp,v 1.1 2001/02/11 14:21:51 dtc Rel $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Stuff to handle allocating simple objects.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "PPC")
+
+;;; But we do everything inline now that we have a better pseudo-atomic.
diff --git a/assembly/ppc/arith.lisp b/assembly/ppc/arith.lisp
new file mode 100644
index 000000000..b47b89ca3
--- /dev/null
+++ b/assembly/ppc/arith.lisp
@@ -0,0 +1,443 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/arith.lisp,v 1.1 2001/02/11 14:21:52 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Stuff to handle simple cases for generic arithmetic.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "PPC")
+
+
+
+;;;; Addition and subtraction.
+
+(define-assembly-routine 
+  (generic-+
+   (:cost 10)
+   (:return-style :full-call)
+   (:translate +)
+   (:policy :safe)
+   (:save-p t))
+  ((:arg x (descriptor-reg any-reg) a0-offset)
+   (:arg y (descriptor-reg any-reg) a1-offset)
+   
+   (:res res (descriptor-reg any-reg) a0-offset)
+   
+   (:temp temp non-descriptor-reg nl0-offset)
+   (:temp temp2 non-descriptor-reg nl1-offset)
+   (:temp flag non-descriptor-reg nl3-offset)
+   (:temp lra descriptor-reg lra-offset)
+   (:temp nargs any-reg nargs-offset)
+   (:temp ocfp any-reg ocfp-offset))
+  
+  ; Clear the damned "sticky overflow" bit in :cr0 and :xer
+  (inst mcrxr :cr0)
+  (inst or temp x y)
+  (inst andi. temp temp 3)
+  (inst bne DO-STATIC-FUN)
+  (inst addo. temp x y)
+  (inst bns done)
+ 
+  (inst srawi temp x 2)
+  (inst srawi temp2 y 2)
+  (inst add temp2 temp2 temp)
+  (with-fixed-allocation (res flag temp bignum-type (1+ bignum-digits-offset))
+    (storew temp2 res bignum-digits-offset other-pointer-type))
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (inst lwz code-tn null-tn (static-function-offset 'two-arg-+))
+  (inst li nargs (fixnum 2))
+  (inst mr ocfp cfp-tn)
+  (inst mr cfp-tn csp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+
+  DONE
+  (move res temp))
+
+
+(define-assembly-routine 
+  (generic--
+   (:cost 10)
+   (:return-style :full-call)
+   (:translate -)
+   (:policy :safe)
+   (:save-p t))
+  ((:arg x (descriptor-reg any-reg) a0-offset)
+   (:arg y (descriptor-reg any-reg) a1-offset)
+   
+   (:res res (descriptor-reg any-reg) a0-offset)
+   
+   (:temp temp non-descriptor-reg nl0-offset)
+   (:temp temp2 non-descriptor-reg nl1-offset)
+   (:temp flag non-descriptor-reg nl3-offset)
+   (:temp lra descriptor-reg lra-offset)
+   (:temp nargs any-reg nargs-offset)
+   (:temp ocfp any-reg ocfp-offset))
+
+  ; Clear the damned "sticky overflow" bit in :cr0
+  (inst mcrxr :cr0)
+
+  (inst or temp x y)
+  (inst andi. temp temp 3)
+  (inst bne DO-STATIC-FUN)
+
+  (inst subo. temp x y)
+  (inst bns done)
+
+  (inst srawi temp x 2)
+  (inst srawi temp2 y 2)
+  (inst sub temp2 temp temp2)
+  (with-fixed-allocation (res flag temp bignum-type (1+ bignum-digits-offset))
+    (storew temp2 res bignum-digits-offset other-pointer-type))
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (inst lwz code-tn null-tn (static-function-offset 'two-arg--))
+  (inst li nargs (fixnum 2))
+  (inst mr ocfp cfp-tn)
+  (inst mr cfp-tn csp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+
+  DONE
+  (move res temp))
+
+
+
+;;;; Multiplication
+
+
+(define-assembly-routine 
+  (generic-*
+   (:cost 50)
+   (:return-style :full-call)
+   (:translate *)
+   (:policy :safe)
+   (:save-p t))
+  ((:arg x (descriptor-reg any-reg) a0-offset)
+   (:arg y (descriptor-reg any-reg) a1-offset)
+   
+   (:res res (descriptor-reg any-reg) a0-offset)
+   
+   (:temp temp non-descriptor-reg nl0-offset)
+   (:temp lo non-descriptor-reg nl1-offset)
+   (:temp hi non-descriptor-reg nl2-offset)
+   (:temp pa-flag non-descriptor-reg nl3-offset)
+   (:temp lra descriptor-reg lra-offset)
+   (:temp nargs any-reg nargs-offset)
+   (:temp ocfp any-reg ocfp-offset))
+
+  ;; If either arg is not a fixnum, call the static function.  But first ...
+  (inst mcrxr :cr0)
+
+  (inst or temp x y)
+  (inst andi. temp temp 3)
+  ;; Remove the tag from both args, so I don't get so confused.
+  (inst srawi temp x 2)
+  (inst srawi nargs y 2)
+  (inst bne DO-STATIC-FUN)
+
+
+  (inst mullwo. lo nargs temp)
+  (inst srawi hi lo 31)                 ; hi = 32 copies of lo's sign bit
+  (inst bns ONE-WORD-ANSWER)
+  (inst mulhw hi nargs temp)
+  (inst b CONS-BIGNUM)
+  
+  ONE-WORD-ANSWER                       ; We know that all of the overflow bits are clear.
+  (inst addo temp lo lo)
+  (inst addo. res temp temp)
+  (inst bns GO-HOME)
+
+  CONS-BIGNUM
+  ;; Allocate a BIGNUM for the result.
+  (pseudo-atomic (pa-flag :extra (pad-data-block (1+ bignum-digits-offset)))
+    (let ((one-word (gen-label)))
+      (inst ori res alloc-tn other-pointer-type)
+      ;; We start out assuming that we need one word.  Is that correct?
+      (inst srawi temp lo 31)
+      (inst xor. temp temp hi)
+      (inst li temp (logior (ash 1 type-bits) bignum-type))
+      (inst beq one-word)
+      ;; Nope, we need two, so allocate the additional space.
+      (inst addi alloc-tn alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
+			              (pad-data-block (1+ bignum-digits-offset))))
+      (inst li temp (logior (ash 2 type-bits) bignum-type))
+      (storew hi res (1+ bignum-digits-offset) other-pointer-type)
+      (emit-label one-word)
+      (storew temp res 0 other-pointer-type)
+      (storew lo res bignum-digits-offset other-pointer-type)))
+  ;; Out of here
+  GO-HOME
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (inst lwz code-tn null-tn (static-function-offset 'two-arg-*))
+  (inst li nargs (fixnum 2))
+  (inst mr ocfp cfp-tn)
+  (inst mr cfp-tn csp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+
+  LOW-FITS-IN-FIXNUM
+  (move res lo))
+
+(macrolet
+    ((frob (name note cost type sc)
+       `(define-assembly-routine (,name
+				  (:note ,note)
+				  (:cost ,cost)
+				  (:translate *)
+				  (:policy :fast-safe)
+				  (:arg-types ,type ,type)
+				  (:result-types ,type))
+				 ((:arg x ,sc nl0-offset)
+				  (:arg y ,sc nl1-offset)
+				  (:res res ,sc nl0-offset))
+	  ,@(when (eq type 'tagged-num)
+	      `((inst srawi x x 2)))
+          (inst mullw res x y))))
+  (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
+  (frob signed-* "unsigned *" 41 signed-num signed-reg)
+  (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
+
+
+
+;;;; Division.
+
+
+(define-assembly-routine (positive-fixnum-truncate
+			  (:note "unsigned fixnum truncate")
+			  (:cost 45)
+			  (:translate truncate)
+			  (:policy :fast-safe)
+			  (:arg-types positive-fixnum positive-fixnum)
+			  (:result-types positive-fixnum positive-fixnum))
+			 ((:arg dividend any-reg nl0-offset)
+			  (:arg divisor any-reg nl1-offset)
+
+			  (:res quo any-reg nl2-offset)
+			  (:res rem any-reg nl0-offset))
+  (assert (location= rem dividend))
+  (let ((error (generate-error-code nil division-by-zero-error
+				    dividend divisor)))
+    (inst cmpwi divisor 0)
+    (inst beq error))
+    (inst divwu quo dividend divisor)
+    (inst mullw divisor quo divisor)
+    (inst sub rem dividend divisor)
+    (inst slwi quo quo 2))
+
+
+
+(define-assembly-routine (fixnum-truncate
+			  (:note "fixnum truncate")
+			  (:cost 50)
+			  (:policy :fast-safe)
+			  (:translate truncate)
+			  (:arg-types tagged-num tagged-num)
+			  (:result-types tagged-num tagged-num))
+			 ((:arg dividend any-reg nl0-offset)
+			  (:arg divisor any-reg nl1-offset)
+
+			  (:res quo any-reg nl2-offset)
+			  (:res rem any-reg nl0-offset))
+  
+  (assert (location= rem dividend))
+  (let ((error (generate-error-code nil division-by-zero-error
+				    dividend divisor)))
+    (inst cmpwi divisor 0)
+    (inst beq error))
+
+    (inst divw quo dividend divisor)
+    (inst mullw divisor quo divisor)
+    (inst subf rem divisor dividend)
+    (inst slwi quo quo 2))
+
+
+(define-assembly-routine (signed-truncate
+			  (:note "(signed-byte 32) truncate")
+			  (:cost 60)
+			  (:policy :fast-safe)
+			  (:translate truncate)
+			  (:arg-types signed-num signed-num)
+			  (:result-types signed-num signed-num))
+
+			 ((:arg dividend signed-reg nl0-offset)
+			  (:arg divisor signed-reg nl1-offset)
+
+			  (:res quo signed-reg nl2-offset)
+			  (:res rem signed-reg nl0-offset))
+  
+  (let ((error (generate-error-code nil division-by-zero-error
+				    dividend divisor)))
+    (inst cmpwi divisor 0)
+    (inst beq error))
+
+    (inst divw quo dividend divisor)
+    (inst mullw divisor quo divisor)
+    (inst subf rem divisor dividend))
+
+
+;;;; Comparison
+
+(macrolet
+    ((define-cond-assem-rtn (name translate static-fn cmp)
+       `(define-assembly-routine 
+          (,name
+           (:cost 10)
+           (:return-style :full-call)
+           (:policy :safe)
+           (:translate ,translate)
+           (:save-p t))
+          ((:arg x (descriptor-reg any-reg) a0-offset)
+           (:arg y (descriptor-reg any-reg) a1-offset)
+           
+           (:res res descriptor-reg a0-offset)
+           
+           (:temp nargs any-reg nargs-offset)
+           (:temp ocfp any-reg ocfp-offset))
+                          
+          (inst or nargs x y)
+          (inst andi. nargs nargs 3)
+          (inst cmpw :cr1 x y)
+          (inst beq DO-COMPARE)
+	  
+	  DO-STATIC-FN
+	  (inst lwz code-tn null-tn (static-function-offset ',static-fn))
+	  (inst li nargs (fixnum 2))
+	  (inst mr ocfp cfp-tn)
+	  (inst mr cfp-tn csp-tn)
+	  (inst j code-tn
+		(- (* function-code-offset word-bytes) function-pointer-type))
+	  
+	  DO-COMPARE
+	  (load-symbol res t)
+	  (inst b? :cr1 ,cmp done)
+	  (inst mr res null-tn)
+	  DONE)))
+
+  (define-cond-assem-rtn generic-< < two-arg-< :lt)
+  (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
+  (define-cond-assem-rtn generic-> > two-arg-> :gt)
+  (define-cond-assem-rtn generic->= >= two-arg->= :ge))
+
+
+(define-assembly-routine (generic-eql
+			  (:cost 10)
+			  (:return-style :full-call)
+			  (:policy :safe)
+			  (:translate eql)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+			  
+			  (:res res descriptor-reg a0-offset)
+
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst cmpw :cr1 x y)
+  (inst andi. nargs x 3)
+  (inst beq :cr1 RETURN-T)
+  (inst beq RETURN-NIL)                 ; x was fixnum, not eq y
+  (inst andi. nargs y 3)
+  (inst bne DO-STATIC-FN)
+
+  RETURN-NIL
+  (inst mr res null-tn)
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FN
+  (inst lwz code-tn null-tn (static-function-offset 'eql))
+  (inst li nargs (fixnum 2))
+  (inst mr ocfp cfp-tn)
+  (inst mr cfp-tn csp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+
+  RETURN-T
+  (load-symbol res t))
+
+(define-assembly-routine 
+  (generic-=
+   (:cost 10)
+   (:return-style :full-call)
+   (:policy :safe)
+   (:translate =)
+   (:save-p t))
+  ((:arg x (descriptor-reg any-reg) a0-offset)
+   (:arg y (descriptor-reg any-reg) a1-offset)
+   
+   (:res res descriptor-reg a0-offset)
+   
+   (:temp lra descriptor-reg lra-offset)
+   (:temp nargs any-reg nargs-offset)
+   (:temp ocfp any-reg ocfp-offset))
+
+  (inst or nargs x y)
+  (inst andi. nargs nargs 3)
+  (inst cmpw :cr1 x y)
+  (inst bne DO-STATIC-FN)
+  (inst beq :cr1 RETURN-T)
+
+  (inst mr res null-tn)
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FN
+  (inst lwz code-tn null-tn (static-function-offset 'two-arg-=))
+  (inst li nargs (fixnum 2))
+  (inst mr ocfp cfp-tn)
+  (inst mr cfp-tn csp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+
+  RETURN-T
+  (load-symbol res t))
+
+(define-assembly-routine (generic-/=
+			  (:cost 10)
+			  (:return-style :full-call)
+			  (:policy :safe)
+			  (:translate /=)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+
+			  (:res res descriptor-reg a0-offset)
+
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst or nargs x y)
+  (inst andi. nargs nargs 3)
+  (inst cmpw :cr1 x y)
+  (inst bne DO-STATIC-FN)
+  (inst beq :cr1 RETURN-NIL)
+
+  (load-symbol res t)
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FN
+  (inst lwz code-tn null-tn (static-function-offset 'two-arg-=))
+  (inst li nargs (fixnum 2))
+  (inst mr ocfp cfp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+  (inst mr cfp-tn csp-tn)
+
+  RETURN-NIL
+  (inst mr res null-tn))
diff --git a/assembly/ppc/array.lisp b/assembly/ppc/array.lisp
new file mode 100644
index 000000000..5d0f8ac13
--- /dev/null
+++ b/assembly/ppc/array.lisp
@@ -0,0 +1,112 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice 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 Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/array.lisp,v 1.1 2001/02/11 14:21:52 dtc Exp $
+;;;
+;;;    This file contains the support routines for arrays and vectors.
+;;;
+;;; Written by William Lott.
+;;; 
+(in-package "PPC")
+
+
+(define-assembly-routine (allocate-vector
+			  (:policy :fast-safe)
+			  (:translate allocate-vector)
+			  (:arg-types positive-fixnum
+				      positive-fixnum
+				      positive-fixnum))
+			 ((:arg type any-reg a0-offset)
+			  (:arg length any-reg a1-offset)
+			  (:arg words any-reg a2-offset)
+			  (:res result descriptor-reg a0-offset)
+
+			  (:temp ndescr non-descriptor-reg nl0-offset)
+			  (:temp pa-flag non-descriptor-reg nl3-offset)
+			  (:temp vector descriptor-reg a3-offset))
+  (pseudo-atomic (pa-flag)
+    (inst ori vector alloc-tn vm:other-pointer-type)
+    (inst addi ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes))
+    (inst clrrwi ndescr ndescr lowtag-bits)
+    (inst add alloc-tn alloc-tn ndescr)
+    (inst srwi ndescr type vm:word-shift)
+    (storew ndescr vector 0 vm:other-pointer-type)
+    (storew length vector vm:vector-length-slot vm:other-pointer-type))
+  (move result vector))
+
+
+
+;;;; Hash primitives
+
+#+assembler
+(defparameter sxhash-simple-substring-entry (gen-label))
+
+(define-assembly-routine (sxhash-simple-string
+			  (:translate %sxhash-simple-string)
+			  (:policy :fast-safe)
+			  (:result-types positive-fixnum))
+			 ((:arg string descriptor-reg a0-offset)
+			  (:res result any-reg a0-offset)
+
+			  (:temp length any-reg a1-offset)
+			  (:temp accum non-descriptor-reg nl0-offset)
+			  (:temp data non-descriptor-reg nl1-offset)
+			  (:temp temp non-descriptor-reg nl2-offset)
+			  (:temp offset non-descriptor-reg nl3-offset))
+
+  (declare (ignore result accum data temp offset))
+
+  (loadw length string vm:vector-length-slot vm:other-pointer-type)
+  (inst b sxhash-simple-substring-entry))
+
+
+(define-assembly-routine (sxhash-simple-substring
+			  (:translate %sxhash-simple-substring)
+			  (:policy :fast-safe)
+			  (:arg-types * positive-fixnum)
+			  (:result-types positive-fixnum))
+			 ((:arg string descriptor-reg a0-offset)
+			  (:arg length any-reg a1-offset)
+			  (:res result any-reg a0-offset)
+
+			  (:temp accum non-descriptor-reg nl0-offset)
+			  (:temp data non-descriptor-reg nl1-offset)
+			  (:temp temp non-descriptor-reg nl2-offset)
+			  (:temp offset non-descriptor-reg nl3-offset))
+  (emit-label sxhash-simple-substring-entry)
+
+  (inst li offset (- (* vector-data-offset word-bytes) other-pointer-type))
+  (move accum zero-tn)
+  (inst b test)
+
+  LOOP
+
+  (inst xor accum accum data)
+  (inst slwi temp accum 27)
+  (inst srwi accum accum 5)
+  (inst or accum accum temp)
+  (inst addi offset offset 4)
+
+  TEST
+
+  (inst subic. length length (fixnum 4))
+  (inst lwzx data string offset)
+  (inst bge loop)
+
+  (inst addic. length length (fixnum 4))
+  (inst neg length length)
+  (inst beq done)
+  (inst slwi length length 1)
+  (inst srw data data length)
+  (inst xor accum accum data)
+
+  DONE
+
+  (inst slwi result accum 5)
+  (inst srwi result result 3))
diff --git a/assembly/ppc/assem-rtns.lisp b/assembly/ppc/assem-rtns.lisp
new file mode 100644
index 000000000..b35d8ab20
--- /dev/null
+++ b/assembly/ppc/assem-rtns.lisp
@@ -0,0 +1,219 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice 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 Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/assem-rtns.lisp,v 1.1 2001/02/11 14:21:52 dtc Exp $
+;;;
+;;;
+(in-package "PPC")
+
+
+;;;; Return-multiple with other than one value
+
+#+assembler ;; we don't want a vop for this one.
+(define-assembly-routine
+    (return-multiple
+     (:return-style :none))
+
+     ;; These four are really arguments.
+    ((:temp nvals any-reg nargs-offset)
+     (:temp vals any-reg nl0-offset)
+     (:temp ocfp any-reg nl1-offset)
+     (:temp lra descriptor-reg lra-offset)
+
+     ;; These are just needed to facilitate the transfer
+     (:temp count any-reg nl2-offset)
+     (:temp src any-reg nl3-offset)
+     (:temp dst any-reg cfunc-offset)
+     (:temp temp descriptor-reg l0-offset)
+
+     ;; These are needed so we can get at the register args.
+     (:temp a0 descriptor-reg a0-offset)
+     (:temp a1 descriptor-reg a1-offset)
+     (:temp a2 descriptor-reg a2-offset)
+     (:temp a3 descriptor-reg a3-offset))
+
+  ;; Note, because of the way the return-multiple vop is written, we can
+  ;; assume that we are never called with nvals == 1 and that a0 has already
+  ;; been loaded.
+  (inst cmpwi nvals 0)
+  (inst ble default-a0-and-on)
+  (inst cmpwi nvals (fixnum 2))
+  (inst lwz a1 vals (* 1 vm:word-bytes))
+  (inst ble default-a2-and-on)
+  (inst cmpwi nvals (fixnum 3))
+  (inst lwz a2 vals (* 2 vm:word-bytes))
+  (inst ble default-a3-and-on)
+  (inst cmpwi nvals (fixnum 4))
+  (inst lwz a3 vals (* 3 vm:word-bytes))
+  (inst ble done)
+
+  ;; Copy the remaining args to the top of the stack.
+  (inst addi src vals (* 4 vm:word-bytes))
+  (inst addi dst cfp-tn (* 4 vm:word-bytes))
+  (inst addic. count nvals (- (fixnum 4)))
+
+  LOOP
+  (inst subic. count count (fixnum 1))
+  (inst lwz temp src 0)
+  (inst addi src src vm:word-bytes)
+  (inst stw temp dst 0)
+  (inst addi dst dst vm:word-bytes)
+  (inst bge loop)
+		
+  (inst b done)
+
+  DEFAULT-A0-AND-ON
+  (inst mr a0 null-tn)
+  (inst mr a1 null-tn)
+  DEFAULT-A2-AND-ON
+  (inst mr a2 null-tn)
+  DEFAULT-A3-AND-ON
+  (inst mr a3 null-tn)
+  DONE
+  
+  ;; Clear the stack.
+  (move ocfp-tn cfp-tn)
+  (move cfp-tn ocfp)
+  (inst add csp-tn ocfp-tn nvals)
+  
+  ;; Return.
+  (lisp-return lra))
+
+
+
+;;;; tail-call-variable.
+
+#+assembler ;; no vop for this one either.
+(define-assembly-routine
+    (tail-call-variable
+     (:return-style :none))
+
+    ;; These are really args.
+    ((:temp args any-reg nl0-offset)
+     (:temp lexenv descriptor-reg lexenv-offset)
+
+     ;; We need to compute this
+     (:temp nargs any-reg nargs-offset)
+
+     ;; These are needed by the blitting code.
+     (:temp src any-reg nl1-offset)
+     (:temp dst any-reg nl2-offset)
+     (:temp count any-reg nl3-offset)
+     (:temp temp descriptor-reg l0-offset)
+
+     ;; These are needed so we can get at the register args.
+     (:temp a0 descriptor-reg a0-offset)
+     (:temp a1 descriptor-reg a1-offset)
+     (:temp a2 descriptor-reg a2-offset)
+     (:temp a3 descriptor-reg a3-offset))
+
+
+  ;; Calculate NARGS (as a fixnum)
+  (inst sub nargs csp-tn args)
+     
+  ;; Load the argument regs (must do this now, 'cause the blt might
+  ;; trash these locations)
+  (inst lwz a0 args (* 0 vm:word-bytes))
+  (inst lwz a1 args (* 1 vm:word-bytes))
+  (inst lwz a2 args (* 2 vm:word-bytes))
+  (inst lwz a3 args (* 3 vm:word-bytes))
+
+  ;; Calc SRC, DST, and COUNT
+  (inst addic. count nargs (fixnum (- register-arg-count)))
+  (inst addi src args (* vm:word-bytes register-arg-count))
+  (inst ble done)
+  (inst addi dst cfp-tn (* vm:word-bytes register-arg-count))
+	
+  LOOP
+  ;; Copy one arg.
+  (inst lwz temp src 0)
+  (inst addi src src vm:word-bytes)
+  (inst stw temp dst 0)
+  (inst addic. count count (fixnum -1))
+  (inst addi dst dst vm:word-bytes)
+  (inst bgt loop)
+	
+  DONE
+  ;; We are done.  Do the jump.
+  (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type)
+  (lisp-jump temp))
+
+
+
+;;;; Non-local exit noise.
+
+(define-assembly-routine (unwind
+			  (:return-style :none)
+			  (:translate %continue-unwind)
+			  (:policy :fast-safe))
+			 ((:arg block (any-reg descriptor-reg) a0-offset)
+			  (:arg start (any-reg descriptor-reg) ocfp-offset)
+			  (:arg count (any-reg descriptor-reg) nargs-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp cur-uwp any-reg nl0-offset)
+			  (:temp next-uwp any-reg nl1-offset)
+			  (:temp target-uwp any-reg nl2-offset))
+  (declare (ignore start count))
+
+  (let ((error (generate-error-code nil invalid-unwind-error)))
+    (inst cmpwi block 0)
+    (inst beq error))
+  
+  (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
+  (loadw target-uwp block vm:unwind-block-current-uwp-slot)
+  (inst cmpw cur-uwp target-uwp)
+  (inst bne do-uwp)
+      
+  (move cur-uwp block)
+
+  DO-EXIT
+      
+  (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot)
+  (loadw code-tn cur-uwp vm:unwind-block-current-code-slot)
+  (loadw lra cur-uwp vm:unwind-block-entry-pc-slot)
+  (lisp-return lra :frob-code nil)
+
+  DO-UWP
+
+  (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot)
+  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)
+  (inst b do-exit))
+
+
+(define-assembly-routine (throw
+			  (:return-style :none))
+			 ((:arg target descriptor-reg a0-offset)
+			  (:arg start any-reg ocfp-offset)
+			  (:arg count any-reg nargs-offset)
+			  (:temp catch any-reg a1-offset)
+			  (:temp tag descriptor-reg a2-offset))		  
+  
+  (declare (ignore start count))
+
+  (load-symbol-value catch lisp::*current-catch-block*)
+  
+  loop
+  
+  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+    (inst cmpwi catch 0)
+    (inst beq error))
+  
+  (loadw tag catch vm:catch-block-tag-slot)
+  (inst cmpw tag target)
+  (inst beq exit)
+  (loadw catch catch vm:catch-block-previous-catch-slot)
+  (inst b loop)
+  
+  exit
+  
+  (move target catch)
+  (inst ba (make-fixup 'unwind :assembly-routine)))
+
+
+
diff --git a/assembly/ppc/support.lisp b/assembly/ppc/support.lisp
new file mode 100644
index 000000000..0f7f1224e
--- /dev/null
+++ b/assembly/ppc/support.lisp
@@ -0,0 +1,65 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/support.lisp,v 1.1 2001/02/11 14:21:52 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+(in-package "PPC")
+
+(def-vm-support-routine generate-call-sequence (name style vop)
+  (ecase style
+    (:raw
+     (values 
+      `((inst bla (make-fixup ',name :assembly-routine)))
+      `()))
+    (: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 ,lra code-tn lra-label ,temp)
+	    (note-next-instruction ,vop :call-site)
+            (inst ba (make-fixup ',name :assembly-routine))
+	    (emit-return-pc lra-label)
+	    (note-this-location ,vop :single-value-return)
+	    (without-scheduling ()
+				(move csp-tn ocfp-tn)
+				(inst nop))
+	    (inst compute-code-from-lra code-tn code-tn
+		  lra-label ,temp)
+	    (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
+     (values 
+      `((inst ba  (make-fixup ',name :assembly-routine)))
+      `()))))
+
+(def-vm-support-routine generate-return-sequence (style)
+  (ecase style
+    (:raw
+     `((inst blr)))
+    (:full-call
+     `((lisp-return (make-random-tn :kind :normal
+				    :sc (sc-or-lose 'descriptor-reg *backend*)
+				    :offset lra-offset)
+		    :offset 2)))
+    (:none)))
diff --git a/code/exports.lisp b/code/exports.lisp
index 1d359ac72..ef339a104 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.177 2001/01/22 10:49:43 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.178 2001/02/11 14:21:59 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -68,6 +68,10 @@
 (if (find-package "SGI")
     (rename-package "SGI" "SGI" '("VM" "OLD-SGI"))
     (make-package "SGI" :nicknames '("VM" "OLD-SGI") :use nil))
+#+ppc
+(if (find-package "PPC")
+    (rename-package "PPC" "PPC" '("VM" "OLD-PPC"))
+    (make-package "PPC" :nicknames '("VM" "OLD-PPC")))
 (if (find-package "CONDITIONS")
     (rename-package "CONDITIONS" "CONDITIONS" 'nil)
     (make-package "CONDITIONS" :nicknames 'nil :use nil))
@@ -618,11 +622,11 @@
        "DOUBLE-FLOAT-P" "LONG-FLOAT-P" "SIMPLE-ARRAY-P" "SINGLE-FLOAT-P"))
   (intern name "KERNEL"))
 (defpackage #+pmax "PMAX" #+sparc "SPARC" #+ibmrt "RT"
-            #+x86 "X86" #+hppa "HPPA" #+alpha "ALPHA" #+sgi "SGI"
+            #+x86 "X86" #+hppa "HPPA" #+alpha "ALPHA" #+sgi "SGI" #+ppc "PPC"
             (:nicknames "VM" #+(or pmax sgi) "MIPS"
 			#+pmax "OLD-MIPS" #+sparc "OLD-SPARC" #+ibmrt "OLD-RT"
 			#+x86 "OLD-X86" #+hppa "HPPA" #+alpha "OLD-ALPHA"
-			#+sgi "OLD-SGI")
+			#+sgi "OLD-SGI" #+ppc "OLD-PPC")
             (:import-from "LISP" "%ARRAY-TYPEP" "%ASET" "%BITSET" "%CHARSET"
              "%PUT" "%RPLACA" "%RPLACD" "%SBITSET" "%SCHARSET"
              "%SET-FDEFINITION" "%SET-FILL-POINTER"
diff --git a/code/ppc-vm.lisp b/code/ppc-vm.lisp
new file mode 100644
index 000000000..d7bc6b9a0
--- /dev/null
+++ b/code/ppc-vm.lisp
@@ -0,0 +1,261 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/code/ppc-vm.lisp,v 1.1 2001/02/11 14:22:01 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the SPARC specific runtime stuff.
+;;;
+(in-package "PPC")
+(use-package "SYSTEM")
+(use-package "UNIX")
+
+(export '(fixup-code-object internal-error-arguments
+	  sigcontext-program-counter sigcontext-register
+	  sigcontext-float-register sigcontext-floating-point-modes
+	  extern-alien-name sanctify-for-execution))
+
+
+;;;; The sigcontext structure.
+;;;; Note that the layout of this thing matches the word offsets PT_xxx, not
+;;;; (necessarily) the pt_regs structure.
+(def-alien-type sigcontext-regs
+  (struct nil
+    (regs (array unsigned-long 32))
+    (pc system-area-pointer)
+    (msr unsigned-long)
+    (orig-r3 unsigned-long)
+    (ctr unsigned-long)
+    (lr unsigned-long)
+    (xer unsigned-long)
+    (ccr unsigned-long)
+    (mq unsigned-long)
+    (trap unsigned-long)
+    (dar unsigned-long)
+    (dsisr unsigned-long)
+    (result unsigned-long)
+    (pad (array unsigned-long 4))
+    (fpregs (array unsigned-long 64))
+    (pad2 unsigned-long)
+    (fpscr unsigned-long)))
+
+(def-alien-type sigcontext
+  (struct nil
+    (sc-unused (array unsigned-long 4))
+    (sc-signal int)
+    (sc-handler unsigned-long)
+    (sc-oldmask unsigned-long)
+    (sc-regs (* sigcontext-regs))))
+
+
+
+;;;; Add machine specific features to *features*
+
+(pushnew :ppc *features*)
+
+
+
+;;;; MACHINE-TYPE and MACHINE-VERSION
+
+(defun machine-type ()
+  "Returns a string describing the type of the local machine."
+  "PowerPC")
+
+(defun machine-version ()
+  "Returns a string describing the version of the local machine."
+  "who-knows?")
+
+
+
+;;; FIXUP-CODE-OBJECT -- Interface
+;;;
+(defun fixup-code-object (code offset fixup kind)
+  (declare (type index offset))
+  (unless (zerop (rem offset ppc:word-bytes))
+    (error "Unaligned instruction?  offset=#x~X." offset))
+  (system:without-gcing
+   (let ((sap (truly-the system-area-pointer
+			 (%primitive c::code-instructions code))))
+     (ecase kind
+       (:b
+	(error "Can't deal with CALL fixups, yet."))
+       (:ba
+	(setf (ldb (byte 24 2) (sap-ref-32 sap offset))
+	      (ash fixup -2)))
+       (:ha
+	(let* ((h (ldb (byte 16 16) fixup))
+	       (l (ldb (byte 16 0) fixup)))
+	  ; Compensate for possible sign-extension when the low half
+	  ; is added to the high.  We could avoid this by ORI-ing
+	  ; the low half in 32-bit absolute loads, but it'd be
+	  ; nice to be able to do:
+	  ;  lis rX,foo@ha
+	  ;  lwz rY,foo@l(rX)
+	  ; and lwz/stw and friends all use a signed 16-bit offset.
+	  (setf (ldb (byte 16 0) (sap-ref-32 sap offset))
+		 (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
+       (:l
+	(setf (ldb (byte 16 0) (sap-ref-32 sap offset))
+	      (ldb (byte 16 0) fixup)))))))
+
+
+
+;;;; Internal-error-arguments.
+
+;;; INTERNAL-ERROR-ARGUMENTS -- interface.
+;;;
+;;; Given the sigcontext, extract the internal error arguments from the
+;;; instruction stream.
+;;; 
+(defun internal-error-arguments (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (let* ((pc (with-alien ((scp (* sigcontext) scp))
+	       (slot (slot scp 'sc-regs) 'pc)))
+	 (bad-inst (sap-ref-32 pc 0))
+	 (op (ldb (byte 16 16) bad-inst)))
+    (declare (type system-area-pointer pc))
+    (cond ((= op (logior (ash 3 10) (ash 6 5)))
+	   (args-for-unimp-inst scp))
+	  ((and (= (ldb (byte 6 10) op) 3)
+		(= (ldb (byte 5 5) op) 24))
+	   (let* ((regnum (ldb (byte 5 0) op))
+		  (prev (sap-ref-32 (int-sap (- (sap-int pc) 4)) 0)))
+	     (if (and (= (ldb (byte 6 26) prev) 3)
+		      (= (ldb (byte 5 21) prev) 0))
+		 (values (ldb (byte 16 0) prev)
+			 (list (c::make-sc-offset ppc:any-reg-sc-number
+						  (ldb (byte 5 16) prev))))
+		 (values #.(kernel:error-number-or-lose
+			    'kernel:invalid-argument-count-error)
+		     (list (c::make-sc-offset ppc:any-reg-sc-number regnum))))))
+
+	  (t
+	   (values #.(error-number-or-lose 'unknown-error) nil)))))
+
+(defun args-for-unimp-inst (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (let* ((pc (with-alien ((scp (* sigcontext) scp))
+	       (slot (slot scp 'sc-regs) 'pc)))
+	 (length (sap-ref-8 pc 4))
+	 (vector (make-array length :element-type '(unsigned-byte 8))))
+    (declare (type system-area-pointer pc)
+	     (type (unsigned-byte 8) length)
+	     (type (simple-array (unsigned-byte 8) (*)) vector))
+    (copy-from-system-area pc (* ppc:byte-bits 5)
+			   vector (* ppc:word-bits
+				     ppc:vector-data-offset)
+			   (* length ppc:byte-bits))
+    (let* ((index 0)
+	   (error-number (c::read-var-integer vector index)))
+      (collect ((sc-offsets))
+	       (loop
+		(when (>= index length)
+		  (return))
+		(sc-offsets (c::read-var-integer vector index)))
+	       (values error-number (sc-offsets))))))
+
+
+
+;;;; Sigcontext access functions.
+
+;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
+;;;
+(defun sigcontext-program-counter (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+	       (slot (slot scp 'sc-regs) 'pc)))
+
+;;; SIGCONTEXT-REGISTER -- Interface.
+;;;
+;;; An escape register saves the value of a register for a frame that someone
+;;; interrupts.  
+;;;
+(defun sigcontext-register (scp index)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (deref (slot (slot scp 'sc-regs) 'regs) index)))
+
+(defun %set-sigcontext-register (scp index new)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (setf (deref (slot (slot scp 'sc-regs) 'regs) index) new)
+    new))
+
+(defsetf sigcontext-register %set-sigcontext-register)
+
+
+;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface
+;;;
+;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
+;;; Format is the type of float to return.
+;;;
+(defun sigcontext-float-register (scp index format)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((sap (alien-sap (slot (slot scp 'sc-regs) 'fpregs))))
+      (ecase format
+	(single-float (float (system:sap-ref-double sap (* index 2 ppc:word-bytes)) 0.0d0))
+	(double-float (system:sap-ref-double sap (* index 2 ppc:word-bytes)))))))
+;;;
+(defun %set-sigcontext-float-register (scp index format new-value)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((sap (alien-sap (slot (slot scp 'sc-regs) 'fpregs))))
+      (ecase format
+	(single-float
+	 (setf (sap-ref-double sap (* index 2 ppc:word-bytes))
+	       (coerce new-value 'double-float)))
+	(double-float
+	 (setf (sap-ref-double sap (* index 2 ppc:word-bytes)) new-value))))))
+;;;
+(defsetf sigcontext-float-register %set-sigcontext-float-register)
+
+
+;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
+;;;
+;;;    Given a sigcontext pointer, return the floating point modes word in the
+;;; same format as returned by FLOATING-POINT-MODES.
+;;;
+(defun sigcontext-floating-point-modes (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (slot (slot scp 'sc-regs) 'fpscr)))
+
+
+
+;;; EXTERN-ALIEN-NAME -- interface.
+;;;
+;;; The loader uses this to convert alien names to the form they occure in
+;;; the symbol table (for example, prepending an underscore).  On the SPARC,
+;;; we prepend an underscore.
+;;; 
+(defun extern-alien-name (name)
+  (declare (type simple-base-string name))
+  (concatenate 'string "" name))
+
+
+
+;;; SANCTIFY-FOR-EXECUTION -- Interface.
+;;;
+;;; Do whatever is necessary to make the given code component executable.
+;;; On the 601, we have less to do than on some other PowerPC chips.
+;;; This should what needs to be done in the general case.
+;;; 
+(defun sanctify-for-execution (component)
+  (without-gcing
+    (alien-funcall (extern-alien "ppc_flush_icache"
+				 (function void
+					   system-area-pointer
+					   unsigned-long))
+		   (code-instructions component)
+		   (* (code-header-ref component code-code-size-slot)
+		      word-bytes)))
+  nil)
+
diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp
index dcf39281e..64fe37f43 100644
--- a/compiler/generic/new-genesis.lisp
+++ b/compiler/generic/new-genesis.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.40 2000/10/23 20:20:48 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.41 2001/02/11 14:22:02 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -862,7 +862,8 @@
     (write-indexed fdefn vm:fdefn-raw-addr-slot
 		   (ecase type
 		     (#.vm:function-header-type
-		      (if (c:backend-featurep :sparc)
+		      (if (or (c:backend-featurep :sparc)
+			      (c:backend-featurep :ppc))
 			  defn
 			  (make-random-descriptor
 			   (+ (logandc2 (descriptor-bits defn) vm:lowtag-mask)
@@ -1850,7 +1851,8 @@
 		    #.c:rt-afpa-fasl-file-implementation
 		    #.c:hppa-fasl-file-implementation
 		    #.c:alpha-fasl-file-implementation
-		    #.c:sgi-fasl-file-implementation)
+		    #.c:sgi-fasl-file-implementation
+		    #.c:ppc-fasl-file-implementation)
 		   "")
 		  (#.c:sparc-fasl-file-implementation
 		   (if (c:backend-featurep :svr4)
@@ -2077,7 +2079,20 @@
 	 (:addi
 	  (setf (sap-ref-16 sap 2)
 		(maybe-byte-swap-short
-		 (ldb (byte 16 0) value))))))))
+		 (ldb (byte 16 0) value))))))
+      (#.c:ppc-fasl-file-implementation
+       (ecase kind
+	 (:ba
+ 	  (setf (sap-ref-32 sap 0)
+ 		(dpb (ash value -2) (byte 24 2) (sap-ref-32 sap 0))))
+ 	 (:ha
+ 	  (let* ((h (ldb (byte 16 16) value))
+ 		 (l (ldb (byte 16 0) value)))
+ 	    (setf (sap-ref-16 sap 2)
+ 		  (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
+ 	 (:l
+  	  (setf (sap-ref-16 sap 2)
+  		(ldb (byte 16 0) value)))))))
   (undefined-value))
 
 (defun linkage-info-to-core ()
diff --git a/compiler/generic/objdef.lisp b/compiler/generic/objdef.lisp
index 947e97d0d..e62a0c64f 100644
--- a/compiler/generic/objdef.lisp
+++ b/compiler/generic/objdef.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.44 1998/07/24 17:22:31 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.45 2001/02/11 14:22:03 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -96,11 +96,11 @@
 ;;; 
 (defenum (:suffix -type)
   even-fixnum
-  function-pointer
+  #-ppc function-pointer #+ppc instance-pointer
   other-immediate-0
   list-pointer
   odd-fixnum
-  instance-pointer
+  #-ppc instance-pointer #+ppc function-pointer
   other-immediate-1
   other-pointer)
 
@@ -303,6 +303,7 @@
 (define-primitive-object (function :type function
 				   :lowtag function-pointer-type
 				   :header function-header-type)
+  #+ppc (jump-insn)
   #-gengc (self :ref-trans %function-self :set-trans (setf %function-self))
   #+gengc (entry-point :c-type "char *")
   (next :type (or function null)
@@ -330,6 +331,7 @@
 
 (define-primitive-object (closure :lowtag function-pointer-type
 				  :header closure-header-type)
+  #+ppc (jump-insn)
   #-gengc (function :init :arg :ref-trans %closure-function)
   #+gengc (entry-point :c-type "char *")
   (info :rest-p t))
@@ -338,6 +340,7 @@
 			  :lowtag function-pointer-type
 			  :header funcallable-instance-header-type
 			  :alloc-trans %make-funcallable-instance)
+  #+ppc (jump-insn)
   #-gengc
   (function
    :ref-known (flushable) :ref-trans %funcallable-instance-function
diff --git a/compiler/generic/vm-macs.lisp b/compiler/generic/vm-macs.lisp
index c49acd101..6f8298616 100644
--- a/compiler/generic/vm-macs.lisp
+++ b/compiler/generic/vm-macs.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-macs.lisp,v 1.16 1997/01/18 14:31:15 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-macs.lisp,v 1.17 2001/02/11 14:22:03 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -235,7 +235,8 @@
 	  big-endian-fasl-file-implementation
 	  little-endian-fasl-file-implementation
 	  alpha-fasl-file-implementation
-	  sgi-fasl-file-implementation))
+	  sgi-fasl-file-implementation
+	  ppc-fasl-file-implementation))
 
 ;;; Constants for the different implementations.  These are all defined in
 ;;; one place to make sure they are all unique.
@@ -253,6 +254,7 @@
 (defconstant little-endian-fasl-file-implementation 8)
 (defconstant alpha-fasl-file-implementation 9)
 (defconstant sgi-fasl-file-implementation 10)
+(defconstant ppc-fasl-file-implementation 11)
 
 ;;; The maximum number of SCs in any implementation.
 (defconstant sc-number-limit 32)
diff --git a/compiler/ppc/alloc.lisp b/compiler/ppc/alloc.lisp
new file mode 100644
index 000000000..76a9ea747
--- /dev/null
+++ b/compiler/ppc/alloc.lisp
@@ -0,0 +1,201 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/alloc.lisp,v 1.1 2001/02/11 14:22:03 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Allocation VOPs for the PPC port.
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "PPC")
+
+
+;;;; 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)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:info num)
+  (:results (result :scs (descriptor-reg)))
+  (:variant-vars star)
+  (:policy :safe)
+  (:generator 0
+    (cond ((zerop num)
+	   (move result null-tn))
+	  ((and star (= num 1))
+	   (move result (tn-ref-tn things)))
+	  (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 (pa-flag :extra alloc)
+		 (inst clrrwi res alloc-tn lowtag-bits)
+		 (inst ori res res list-pointer-type)
+		 (move ptr res)
+		 (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 ptr ptr (pad-data-block cons-size))
+		   (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 result res)))))))
+
+(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)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:generator 100
+    (inst addi boxed boxed-arg (fixnum (1+ code-trace-table-offset-slot)))
+    (inst clrrwi boxed boxed lowtag-bits)
+    (inst srwi unboxed unboxed-arg word-shift)
+    (inst addi unboxed unboxed lowtag-mask)
+    (inst clrrwi unboxed unboxed lowtag-bits)
+    (pseudo-atomic (pa-flag)
+      ;; Note: we don't have to subtract off the 4 that was added by
+      ;; pseudo-atomic, because oring in other-pointer-type just adds
+      ;; it right back.
+      (inst ori result alloc-tn other-pointer-type)
+      (inst add alloc-tn alloc-tn boxed)
+      (inst add alloc-tn alloc-tn unboxed)
+      (inst slwi ndescr boxed (- type-bits word-shift))
+      (inst ori ndescr ndescr code-header-type)
+      (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)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:results (result :scs (descriptor-reg) :from :argument))
+  (:policy :fast-safe)
+  (:translate make-fdefn)
+  (:generator 37
+    (with-fixed-allocation (result pa-flag temp fdefn-type fdefn-size)
+      (inst lr temp  (make-fixup "undefined_tramp" :foreign))
+      (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))))
+
+
+(define-vop (make-closure)
+  (:args (function :to :save :scs (descriptor-reg)))
+  (:info length)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 10
+    (let ((size (+ length closure-info-offset)))
+      (pseudo-atomic (pa-flag :extra (pad-data-block size))
+	(inst clrrwi. result alloc-tn lowtag-bits)
+	(inst ori result result function-pointer-type)
+	(inst lr temp (logior (ash (1- size) type-bits) closure-header-type))
+	(storew temp result 0 function-pointer-type)))
+    (inst lis temp (ash 18 10))
+    (storew temp result closure-jump-insn-slot function-pointer-type)
+    (storew function result closure-function-slot function-pointer-type)))
+
+;;; The compiler likes to be able to directly make value cells.
+;;; 
+(define-vop (make-value-cell)
+  (:args (value :to :save :scs (descriptor-reg any-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 10
+    (with-fixed-allocation
+	(result pa-flag temp value-cell-header-type value-cell-size))
+    (storew value result value-cell-value-slot other-pointer-type)))
+
+
+
+;;;; Automatic allocators for primitive objects.
+
+(define-vop (make-unbound-marker)
+  (:args)
+  (:results (result :scs (any-reg)))
+  (:generator 1
+    (inst li result unbound-marker-type)))
+
+(define-vop (fixed-alloc)
+  (:args)
+  (:info name words type lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:generator 4
+    (pseudo-atomic (pa-flag :extra (pad-data-block words))
+      (cond ((logbitp 2 lowtag)
+	     (inst ori result alloc-tn lowtag))
+	    (t
+	     (inst clrrwi result alloc-tn lowtag-bits)
+	     (inst ori result  result lowtag)))
+      (when type
+	(inst lr temp (logior (ash (1- words) type-bits) type))
+	(storew temp result 0 lowtag)))))
+
+(define-vop (var-alloc)
+  (:args (extra :scs (any-reg)))
+  (:arg-types positive-fixnum)
+  (:info name words type lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (any-reg)) bytes header)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:generator 6
+    (inst addi bytes extra (* (1+ words) word-bytes))
+    (inst slwi header bytes (- type-bits 2))
+    (inst addi header header (+ (ash -2 type-bits) type))
+    (inst clrrwi bytes bytes lowtag-bits)
+    (pseudo-atomic (pa-flag)
+      (cond ((logbitp 2 lowtag)
+	     (inst ori result alloc-tn lowtag))
+	    (t
+	     (inst clrrwi result alloc-tn lowtag-bits)
+	     (inst ori result result lowtag)))
+      (storew header result 0 lowtag)
+      (inst add alloc-tn alloc-tn bytes))))
diff --git a/compiler/ppc/arith.lisp b/compiler/ppc/arith.lisp
new file mode 100644
index 000000000..0f991a931
--- /dev/null
+++ b/compiler/ppc/arith.lisp
@@ -0,0 +1,923 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice 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 Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/arith.lisp,v 1.1 2001/02/11 14:22:04 dtc Exp $
+;;;
+;;;    This file contains the VM definition arithmetic VOPs for the MIPS.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by William Lott.
+;;; 
+
+(in-package "PPC")
+
+
+
+;;;; Unary operations.
+
+(define-vop (fast-safe-arith-op)
+  (:policy :fast-safe)
+  (:effects)
+  (:affected))
+
+
+(define-vop (fixnum-unop fast-safe-arith-op)
+  (:args (x :scs (any-reg)))
+  (:results (res :scs (any-reg)))
+  (:note "inline fixnum arithmetic")
+  (:arg-types tagged-num)
+  (:result-types tagged-num))
+
+(define-vop (signed-unop fast-safe-arith-op)
+  (:args (x :scs (signed-reg)))
+  (:results (res :scs (signed-reg)))
+  (:note "inline (signed-byte 32) arithmetic")
+  (:arg-types signed-num)
+  (:result-types signed-num))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+  (:translate %negate)
+  (:generator 1
+    (inst neg res x)))
+
+(define-vop (fast-negate/signed signed-unop)
+  (:translate %negate)
+  (:generator 2
+    (inst neg res x)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+  (:translate lognot)
+  (:generator 2
+    (inst xori res x (fixnum -1))))
+
+(define-vop (fast-lognot/signed signed-unop)
+  (:translate lognot)
+  (:generator 1
+    (inst not res x)))
+
+
+
+;;;; Binary fixnum operations.
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop fast-safe-arith-op)
+  (:args (x :target r :scs (any-reg zero))
+	 (y :target r :scs (any-reg zero)))
+  (:arg-types tagged-num tagged-num)
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg zero))
+	 (y :target r :scs (unsigned-reg zero)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop fast-safe-arith-op)
+  (:args (x :target r :scs (signed-reg zero))
+	 (y :target r :scs (signed-reg zero)))
+  (:arg-types signed-num signed-num)
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic"))
+
+
+(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (any-reg zero)))
+  (:info y)
+  (:arg-types tagged-num
+	      (:constant (and (signed-byte 14) (not (integer 0 0)))))
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic"))
+
+(define-vop (fast-fixnum-logop-c fast-safe-arith-op)
+  (:args (x :target r :scs (any-reg zero)))
+  (:info y)
+  (:arg-types tagged-num
+	      (:constant (and (unsigned-byte 14) (not (integer 0 0)))))
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:note "inline fixnum logical op"))
+
+(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg zero)))
+  (:info y)
+  (:arg-types unsigned-num
+	      (:constant (and (signed-byte 16) (not (integer 0 0)))))
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-unsigned-logop-c fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg zero)))
+  (:info y)
+  (:arg-types unsigned-num
+	      (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) logical op"))
+
+(define-vop (fast-signed-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (signed-reg zero)))
+  (:info y)
+  (:arg-types signed-num
+	      (:constant (and (signed-byte 16) (not (integer 0 0)))))
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic"))
+
+(define-vop (fast-signed-logop-c fast-safe-arith-op)
+  (:args (x :target r :scs (signed-reg zero)))
+  (:info y)
+  (:arg-types signed-num
+	      (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic"))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defmacro define-var-binop (translate untagged-penalty op)
+  `(progn
+     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+		  fast-fixnum-binop)
+       (:translate ,translate)
+       (:generator 2
+	 (inst ,op r x y))) 
+     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+		  fast-signed-binop)
+       (:translate ,translate)
+       (:generator ,(1+ untagged-penalty)
+	 (inst ,op r x y))) 
+     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+		  fast-unsigned-binop)
+       (:translate ,translate)
+       (:generator ,(1+ untagged-penalty)
+	 (inst ,op r x y)))))
+
+
+(defmacro define-const-binop (translate untagged-penalty op)
+  `(progn
+     
+     (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+		  fast-fixnum-binop-c)
+       (:translate ,translate)
+       (:generator 1
+	 (inst ,op r x (fixnum y))))
+     (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+		  fast-signed-binop-c)
+       (:translate ,translate)
+       (:generator ,untagged-penalty
+	 (inst ,op r x y)))
+     (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
+		  fast-unsigned-binop-c)
+       (:translate ,translate)
+       (:generator ,untagged-penalty
+	 (inst ,op r x y)))))
+
+(defmacro define-const-logop (translate untagged-penalty op)
+  `(progn
+     
+     (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+		  fast-fixnum-logop-c)
+       (:translate ,translate)
+       (:generator 1
+	 (inst ,op r x (fixnum y))))
+     (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+		  fast-signed-logop-c)
+       (:translate ,translate)
+       (:generator ,untagged-penalty
+	 (inst ,op r x y)))
+     (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
+		  fast-unsigned-logop-c)
+       (:translate ,translate)
+       (:generator ,untagged-penalty
+	 (inst ,op r x y)))))
+
+); eval-when
+
+(define-var-binop + 4 add)
+(define-var-binop - 4 sub)
+(define-var-binop logand 2 and)
+(define-var-binop logandc2 2 andc)
+(define-var-binop logior 2 or)
+(define-var-binop logorc2 2 orc)
+(define-var-binop logxor 2 xor)
+(define-var-binop logeqv 2 eqv)
+
+(define-const-binop + 4 addi)
+(define-const-binop - 4 subi)
+(define-const-logop logand 2 andi.)
+(define-const-logop logior 2 ori)
+(define-const-logop logxor 2 xori)
+
+
+;;; Special case fixnum + and - that trap on overflow.  Useful when we
+;;; don't know that the output type is a fixnum.
+
+(define-vop (+/fixnum fast-+/fixnum=>fixnum)
+  (:policy :safe)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note "safe inline fixnum arithmetic")
+  (:generator 4
+    (let* ((no-overflow (gen-label)))
+      (inst mcrxr :cr0)
+      (inst addo. r x y)
+      (inst bns no-overflow)
+      (inst unimp (logior (ash (reg-tn-encoding r) 5) fixnum-additive-overflow-trap))
+      (emit-label no-overflow))))
+
+#|
+(define-vop (+-c/fixnum fast-+-c/fixnum=>fixnum)
+  (:policy :safe)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note "safe inline fixnum arithmetic")
+  (:generator 3
+    (inst taddcctv r x (fixnum y))))
+|#
+
+(define-vop (-/fixnum fast--/fixnum=>fixnum)
+  (:policy :safe)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note "safe inline fixnum arithmetic")
+  (:generator 4
+    (let* ((no-overflow (gen-label)))
+      (inst mcrxr :cr0)
+      (inst subo. r x y)
+      (inst bns no-overflow)
+      (inst unimp (logior (ash (reg-tn-encoding r) 5) fixnum-additive-overflow-trap))
+      (emit-label no-overflow))))
+
+#|
+(define-vop (--c/fixnum fast---c/fixnum=>fixnum)
+  (:policy :safe)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note "safe inline fixnum arithmetic")
+  (:generator 3
+    (inst tsubcctv r x (fixnum y))))
+|#
+;;; Shifting
+
+(define-vop (fast-ash)
+  (:note "inline ASH")
+  (:args (number :scs (signed-reg unsigned-reg) :to :save)
+	 (amount :scs (signed-reg immediate)))
+  (:arg-types (:or signed-num unsigned-num) signed-num)
+  (:results (result :scs (signed-reg unsigned-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:translate ash)
+  (:policy :fast-safe)
+  (:temporary (:sc non-descriptor-reg) ndesc)
+  (:generator 3
+    (sc-case amount
+      (signed-reg
+       (let ((positive (gen-label))
+	     (done (gen-label)))
+	 (inst cmpwi amount 0)
+	 (inst neg ndesc amount)
+	 (inst bge positive)
+	 (inst cmpwi ndesc 31)
+	 (sc-case number
+	   (signed-reg (inst sraw result number ndesc))
+	   (unsigned-reg (inst srw result number ndesc)))
+	 (inst ble done)
+	 (sc-case number
+	   (signed-reg (inst srawi result number 31))
+	   (unsigned-reg (inst srwi result number 31)))
+	 (inst b done)
+
+	 (emit-label positive)
+	 ;; The result-type assures us that this shift will not overflow.
+	 (inst slw result number amount)
+
+	 (emit-label done)))
+
+      (immediate
+       (let ((amount (tn-value amount)))
+	 (if (minusp amount)
+	     (let ((amount (min 31 (- amount))))
+	       (sc-case number
+		 (unsigned-reg
+		  (inst srwi result number amount))
+		 (signed-reg
+		  (inst srawi result number amount))))
+	     (inst slwi result number amount)))))))
+
+
+
+(define-vop (signed-byte-32-len)
+  (:translate integer-length)
+  (:note "inline (signed-byte 32) integer-length")
+  (:policy :fast-safe)
+  (:args (arg :scs (signed-reg)))
+  (:arg-types signed-num)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg) :to (:argument 0)) shift)
+  (:generator 6
+    ; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg))))
+    (let ((nonneg (gen-label)))
+      (inst cntlzw. shift arg)
+      (inst bne nonneg)
+      (inst not shift arg)
+      (inst cntlzw shift shift)
+      (emit-label nonneg)
+      (inst slwi shift shift 2)
+      (inst subfic res  shift (fixnum 32)))))
+
+(define-vop (unsigned-byte-32-count)
+  (:translate logcount)
+  (:note "inline (unsigned-byte 32) logcount")
+  (:policy :fast-safe)
+  (:args (arg :scs (unsigned-reg) :target shift))
+  (:arg-types unsigned-num)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp)
+  (:generator 30
+    (let ((loop (gen-label))
+	  (done (gen-label)))
+      (inst add. shift zero-tn arg)
+      (move res zero-tn)
+      (inst beq done)
+
+      (emit-label loop)
+      (inst subi temp shift 1)
+      (inst and. shift shift temp)
+      (inst addi res res (fixnum 1))
+      (inst bne loop)
+
+      (emit-label done))))
+
+
+;;;; Binary conditional VOPs:
+
+(define-vop (fast-conditional)
+  (:conditional)
+  (:info target not-p)
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(deftype integer-with-a-bite-out (s bite)
+  (cond ((eq s '*) 'integer)
+	((and (integerp s) (> s 1))
+	 (let ((bound (ash 1 (1- s))))
+	   `(integer ,(- bound) ,(- bound bite 1))))
+	(t
+	 (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
+
+(define-vop (fast-conditional/fixnum fast-conditional)
+  (:args (x :scs (any-reg zero))
+	 (y :scs (any-reg zero)))
+  (:arg-types tagged-num tagged-num)
+  (:note "inline fixnum comparison"))
+
+(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg zero)))
+  (:arg-types tagged-num (:constant (signed-byte 14)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/signed fast-conditional)
+  (:args (x :scs (signed-reg zero))
+	 (y :scs (signed-reg zero)))
+  (: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 zero)))
+  (:arg-types signed-num (:constant (signed-byte 16)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/unsigned fast-conditional)
+  (:args (x :scs (unsigned-reg zero))
+	 (y :scs (unsigned-reg zero)))
+  (: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 zero)))
+  (:arg-types unsigned-num (:constant (unsigned-byte 16)))
+  (:info target not-p y))
+
+
+(define-vop (fast-if-</fixnum fast-conditional/fixnum)
+  (:translate <)
+  (:generator 4
+    (inst cmpw x y)
+    (inst b? (if not-p :ge :lt) target)))
+
+(define-vop (fast-if-<-c/fixnum fast-conditional-c/fixnum)
+  (:translate <)
+  (:generator 3
+    (inst cmpwi x (fixnum y))
+    (inst b? (if not-p :ge :lt) target)))
+
+(define-vop (fast-if-</signed fast-conditional/signed)
+  (:translate <)
+  (:generator 6
+    (inst cmpw x y)
+    (inst b? (if not-p :ge :lt) target)))
+
+(define-vop (fast-if-<-c/signed fast-conditional-c/signed)
+  (:translate <)
+  (:generator 5
+    (inst cmpwi x y)
+    (inst b? (if not-p :ge :lt) target)))
+
+(define-vop (fast-if-</unsigned fast-conditional/unsigned)
+  (:translate <)
+  (:generator 6
+    (inst cmplw x y)
+    (inst b? (if not-p :ge :lt) target)))
+
+(define-vop (fast-if-<-c/unsigned fast-conditional-c/unsigned)
+  (:translate <)
+  (:generator 5
+    (inst cmplwi x y)
+    (inst b? (if not-p :ge :lt) target)))
+
+(define-vop (fast-if->/fixnum fast-conditional/fixnum)
+  (:translate >)
+  (:generator 4
+    (inst cmpw x y)
+    (inst b? (if not-p :le :gt) target)))
+
+(define-vop (fast-if->-c/fixnum fast-conditional-c/fixnum)
+  (:translate >)
+  (:generator 3
+    (inst cmpwi x (fixnum y))
+    (inst b? (if not-p :le :gt) target)))
+
+(define-vop (fast-if->/signed fast-conditional/signed)
+  (:translate >)
+  (:generator 6
+    (inst cmpw x y)
+    (inst b? (if not-p :le :gt) target)))
+
+(define-vop (fast-if->-c/signed fast-conditional-c/signed)
+  (:translate >)
+  (:generator 5
+    (inst cmpwi x y)
+    (inst b? (if not-p :le :gt) target)))
+
+(define-vop (fast-if->/unsigned fast-conditional/unsigned)
+  (:translate >)
+  (:generator 6
+    (inst cmplw x y)
+    (inst b? (if not-p :le :gt) target)))
+
+(define-vop (fast-if->-c/unsigned fast-conditional-c/unsigned)
+  (:translate >)
+  (:generator 5
+    (inst cmplwi x y)
+    (inst b? (if not-p :le :gt) target)))
+
+(define-vop (fast-if-eql/signed fast-conditional/signed)
+  (:translate eql)
+  (:generator 6
+    (inst cmpw x y)
+    (inst b? (if not-p :ne :eq) target)))
+
+(define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
+  (:translate eql)
+  (:generator 5
+    (inst cmpwi x y)
+    (inst b? (if not-p :ne :eq) target)))
+
+(define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
+  (:translate eql)
+  (:generator 6
+    (inst cmplw x y)
+    (inst b? (if not-p :ne :eq) target)))
+
+(define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
+  (:translate eql)
+  (:generator 5
+    (inst cmplwi x y)
+    (inst b? (if not-p :ne :eq) target)))
+
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+
+;;; 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 zero))
+	 (y :scs (any-reg zero)))
+  (:arg-types tagged-num tagged-num)
+  (:note "inline fixnum comparison")
+  (:translate eql)
+  (:generator 4
+    (inst cmpw x y)
+    (inst b? (if not-p :ne :eq) 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 zero)))
+  (:arg-types tagged-num (:constant (signed-byte 14)))
+  (:info target not-p y)
+  (:translate eql)
+  (:generator 2
+    (inst cmpwi x (fixnum y))
+    (inst b? (if not-p :ne :eq) target)))
+;;;
+(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+  (:arg-types * (:constant (signed-byte 11)))
+  (:variant-cost 6))
+
+
+;;;; 32-bit logical operations
+
+(define-vop (merge-bits)
+  (:translate merge-bits)
+  (:args (shift :scs (signed-reg unsigned-reg))
+	 (prev :scs (unsigned-reg))
+	 (next :scs (unsigned-reg)))
+  (:arg-types tagged-num unsigned-num unsigned-num)
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+  (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 4
+    (let ((done (gen-label)))
+      (inst cmpwi shift 0)
+      (inst beq done)
+      (inst srw res next shift)
+      (inst sub temp zero-tn shift)
+      (inst slw temp prev temp)
+      (inst or res res temp)
+      (emit-label done)
+      (move result res))))
+
+
+(define-vop (32bit-logical)
+  (:args (x :scs (unsigned-reg zero))
+	 (y :scs (unsigned-reg zero)))
+  (: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 zero)))
+  (:arg-types unsigned-num)
+  (:generator 1
+    (inst not r x)))
+
+(define-vop (32bit-logical-and 32bit-logical)
+  (:translate 32bit-logical-and)
+  (:generator 1
+    (inst and r x y)))
+
+(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 r x y)))
+
+(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 r x y)))
+
+(define-vop (32bit-logical-eqv 32bit-logical)
+  (:translate 32bit-logical-eqv)
+  (:generator 1
+    (inst eqv r x y)))
+
+(define-vop (32bit-logical-orc2 32bit-logical)
+  (:translate 32bit-logical-orc2)
+  (:generator 1
+    (inst orc r x y)))
+
+(deftransform 32bit-logical-orc1 ((x y) (* *))
+  '(32bit-logical-orc2 y x))
+
+(define-vop (32bit-logical-andc2 32bit-logical)
+  (:translate 32bit-logical-andc2)
+  (:generator 1
+    (inst andc r x y)))
+
+(deftransform 32bit-logical-andc1 ((x y) (* *))
+  '(32bit-logical-andc2 y x))
+
+
+(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)
+  (:note "shift-towards-start")
+  (:generator 1
+    (inst rlwinm amount amount 0 27 31)
+    (inst slw r num amount)))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+  (:translate shift-towards-end)
+  (:note "shift-towards-end")
+  (:generator 1
+    (inst rlwinm amount amount 0 27 31)
+    (inst srw r num amount)))
+
+
+
+
+;;;; 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-vop (bignum-ref word-index-ref)
+  (:variant vm:bignum-digits-offset vm:other-pointer-type)
+  (:translate bignum::%bignum-ref)
+  (:results (value :scs (unsigned-reg)))
+  (:result-types unsigned-num))
+
+(define-vop (bignum-set word-index-set)
+  (:variant vm:bignum-digits-offset vm:other-pointer-type)
+  (:translate bignum::%bignum-set)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg immediate zero))
+	 (value :scs (unsigned-reg)))
+  (:arg-types t positive-fixnum unsigned-num)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num))
+
+(define-vop (digit-0-or-plus)
+  (:translate bignum::%digit-0-or-plusp)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 3
+    (let ((done (gen-label)))
+      (inst cmpwi digit 0)
+      (move result null-tn)
+      (inst blt done)
+      (load-symbol result t)
+      (emit-label done))))
+
+(define-vop (add-w/carry)
+  (:translate bignum::%add-with-carry)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg))
+	 (b :scs (unsigned-reg))
+	 (c :scs (any-reg)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:temporary (:scs (unsigned-reg)) temp)
+  (:results (result :scs (unsigned-reg))
+	    (carry :scs (unsigned-reg)))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 3
+    (inst addic temp c -1)
+    (inst adde result a b)
+    (inst addze carry zero-tn)))
+
+(define-vop (sub-w/borrow)
+  (:translate bignum::%subtract-with-borrow)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg))
+	 (b :scs (unsigned-reg))
+	 (c :scs (any-reg)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:temporary (:scs (unsigned-reg)) temp)
+  (:results (result :scs (unsigned-reg))
+	    (borrow :scs (unsigned-reg)))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 4
+    (inst addic temp c -1)
+    (inst sube result a b)
+    (inst addze borrow zero-tn)))
+
+(define-vop (bignum-mult-and-add-3-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg))
+	 (carry-in :scs (unsigned-reg) :to (:eval 1)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp)
+  (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
+		    :target lo) lo-temp)
+  (:results (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 40
+    (inst mulhwu hi-temp x y)
+    (inst mullw lo-temp x y)
+    (inst addc lo lo-temp carry-in)
+    (inst addze hi hi-temp)))
+
+(define-vop (bignum-mult-and-add-4-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg))
+	 (prev :scs (unsigned-reg) :to (:eval 1))
+	 (carry-in :scs (unsigned-reg) :to (:eval 1)))
+  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
+  (:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp)
+  (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
+		    :target lo) lo-temp)
+  (:results (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 40
+    (inst mulhwu hi-temp x y)
+    (inst mullw lo-temp x y)
+    (inst addc lo-temp lo-temp carry-in)
+    (inst addze hi-temp hi-temp)
+    (inst addc lo lo-temp prev)
+    (inst addze hi hi-temp)))
+
+(define-vop (bignum-mult)
+  (:translate bignum::%multiply)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg) :to (:result 1))
+	 (y :scs (unsigned-reg) :to (:result 1)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 40
+    (inst mullw lo x y)
+    (inst mulhwu hi x y)))
+
+(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 not r x)))
+
+(define-vop (fixnum-to-digit)
+  (:translate bignum::%fixnum-to-digit)
+  (:policy :fast-safe)
+  (:args (fixnum :scs (any-reg)))
+  (:arg-types tagged-num)
+  (:results (digit :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (inst srawi digit fixnum 2)))
+
+
+(define-vop (bignum-floor)
+  (:translate bignum::%floor)
+  (:policy :fast-safe)
+  (:args (num-high :scs (unsigned-reg) :target rem)
+	 (num-low :scs (unsigned-reg) :target rem-low)
+	 (denom :scs (unsigned-reg) :to (:eval 1)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low)
+  (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
+  (:results (quo :scs (unsigned-reg) :from (:eval 0))
+	    (rem :scs (unsigned-reg) :from (:argument 0)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 325 ; number of inst assuming targeting works.
+    (move rem num-high)
+    (move rem-low num-low)
+    (flet ((maybe-subtract (&optional (guess temp))
+	     (inst subi temp guess 1)
+	     (inst and temp temp denom)
+	     (inst sub rem rem temp))
+	   (sltu (res x y)
+	     (inst subfc res y x)
+	     (inst subfe res res res)
+	     (inst neg res res)))
+      (sltu quo rem denom)
+      (maybe-subtract quo)
+      (dotimes (i 32)
+	(inst slwi rem rem 1)
+	(inst srwi temp rem-low 31)
+	(inst or rem rem temp)
+	(inst slwi rem-low rem-low 1)
+	(sltu temp rem denom)
+	(inst slwi quo quo 1)
+	(inst or quo quo temp)
+	(maybe-subtract)))
+    (inst not quo quo)))
+
+#|
+
+(define-vop (bignum-floor)
+  (:translate bignum::%floor)
+  (:policy :fast-safe)
+  (:args (div-high :scs (unsigned-reg) :target rem)
+	 (div-low :scs (unsigned-reg) :target quo)
+	 (divisor :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:results (quo :scs (unsigned-reg) :from (:argument 1))
+	    (rem :scs (unsigned-reg) :from (:argument 0)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 300
+    (inst mtmq div-low)
+    (inst div quo div-high divisor)
+    (inst mfmq 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 (any-reg signed-reg)))
+  (:result-types signed-num)
+  (:generator 1
+    (sc-case res
+      (any-reg
+       (inst slwi res digit 2))
+      (signed-reg
+       (move res digit)))))
+
+
+(define-vop (digit-ashr)
+  (:translate bignum::%ashr)
+  (: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 1
+    (inst sraw result digit count)))
+
+(define-vop (digit-lshr digit-ashr)
+  (:translate bignum::%digit-logical-shift-right)
+  (:generator 1
+    (inst srw result digit count)))
+
+(define-vop (digit-ashl digit-ashr)
+  (:translate bignum::%ashl)
+  (:generator 1
+    (inst slw result digit count)))
+
+
+;;;; 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 two-arg-* (x y) :translate *)
+(define-static-function two-arg-/ (x y) :translate /)
+
+(define-static-function two-arg-< (x y) :translate <)
+(define-static-function two-arg-<= (x y) :translate <=)
+(define-static-function two-arg-> (x y) :translate >)
+(define-static-function two-arg->= (x y) :translate >=)
+(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/ppc/array.lisp b/compiler/ppc/array.lisp
new file mode 100644
index 000000000..909f54cc7
--- /dev/null
+++ b/compiler/ppc/array.lisp
@@ -0,0 +1,497 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/array.lisp,v 1.1 2001/02/11 14:22:04 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the PPC definitions for array operations.
+;;;
+;;; Written by William Lott
+;;;
+(in-package "PPC")
+
+
+;;;; 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 (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 0
+    (pseudo-atomic (pa-flag)
+      (inst ori header alloc-tn other-pointer-type)
+      (inst addi ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes))
+      (inst clrrwi ndescr ndescr lowtag-bits)
+      (inst add alloc-tn alloc-tn ndescr)
+      (inst addi ndescr rank (fixnum (1- vm:array-dimensions-offset)))
+      (inst slwi ndescr ndescr vm:type-bits)
+      (inst or ndescr ndescr type)
+      (inst srwi ndescr ndescr 2)
+      (storew ndescr header 0 vm:other-pointer-type))
+    (move result header)))
+
+
+;;;; Additional accessors and setters for the array header.
+
+(defknown lisp::%array-dimension (t fixnum) fixnum
+  (flushable))
+(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum
+  ())
+
+(define-vop (%array-dimension word-index-ref)
+  (:translate lisp::%array-dimension)
+  (:policy :fast-safe)
+  (:variant vm:array-dimensions-offset vm:other-pointer-type))
+
+(define-vop (%set-array-dimension word-index-set)
+  (:translate lisp::%set-array-dimension)
+  (:policy :fast-safe)
+  (:variant vm:array-dimensions-offset vm:other-pointer-type))
+
+
+
+(defknown lisp::%array-rank (t) fixnum (flushable))
+
+(define-vop (array-rank-vop)
+  (:translate lisp::%array-rank)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 6
+    (loadw temp x 0 vm:other-pointer-type)
+    (inst srawi temp temp vm:type-bits)
+    (inst subi temp temp (1- vm:array-dimensions-offset))
+    (inst slwi res temp 2)))
+
+
+
+;;;; 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 cmplw index bound)
+      (inst bge error)
+      (move result index))))
+
+
+
+;;;; 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.
+
+(defmacro def-data-vector-frobs (type variant element-type &rest scs)
+  `(progn
+     (define-vop (,(intern (concatenate 'simple-string
+					"DATA-VECTOR-REF/"
+					(string type)))
+		  ,(intern (concatenate 'simple-string
+					(string variant)
+					"-REF")))
+       (:note "inline array access")
+       (:variant vm:vector-data-offset vm:other-pointer-type)
+       (:translate data-vector-ref)
+       (:arg-types ,type positive-fixnum)
+       (:results (value :scs ,scs))
+       (:result-types ,element-type))
+     (define-vop (,(intern (concatenate 'simple-string
+					"DATA-VECTOR-SET/"
+					(string type)))
+		  ,(intern (concatenate 'simple-string
+					(string variant)
+					"-SET")))
+       (:note "inline array store")
+       (:variant vm:vector-data-offset vm:other-pointer-type)
+       (:translate data-vector-set)
+       (:arg-types ,type positive-fixnum ,element-type)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg zero immediate))
+	      (value :scs ,scs))
+       (:results (result :scs ,scs))
+       (:result-types ,element-type))))
+
+(def-data-vector-frobs simple-string byte-index
+  base-char base-char-reg)
+(def-data-vector-frobs simple-vector word-index
+  * descriptor-reg any-reg)
+
+(def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
+  positive-fixnum unsigned-reg)
+(def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
+  positive-fixnum unsigned-reg)
+(def-data-vector-frobs simple-array-unsigned-byte-32 word-index
+  unsigned-num unsigned-reg)
+
+#+signed-array
+(def-data-vector-frobs simple-array-signed-byte-30 word-index
+  tagged-num any-reg)
+#+signed-array
+(def-data-vector-frobs simple-array-signed-byte-32 word-index
+  signed-num signed-reg)
+
+
+;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
+;;; and 4-bit vectors.
+;;; 
+
+(eval-when (:compile-toplevel :execute)
+
+(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 (value :scs (any-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
+	 (:generator 20
+	   (inst srwi temp index ,bit-shift)
+	   (inst slwi temp temp 2)
+	   (inst addi temp temp (- (* vm:vector-data-offset vm:word-bytes)
+			           vm:other-pointer-type))
+	   (inst lwzx result object temp)
+	   (inst andi. temp index ,(1- elements-per-word))
+	   (inst xori temp temp ,(1- elements-per-word))
+	   ,@(unless (= bits 1)
+	       `((inst slwi temp temp ,(1- (integer-length bits)))))
+	   (inst srw result result temp)
+	   (inst andi. result result ,(1- (ash 1 bits)))
+	   (inst slwi value result 2)))
+       (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)
+	     (setf extra (logxor extra (1- ,elements-per-word)))
+	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
+			      vm:other-pointer-type)))
+	       (cond ((typep offset '(signed-byte 16))
+		      (inst lwz result object offset))
+		     (t
+		      (inst lr temp offset)
+		      (inst lwzx result object temp))))
+	     (unless (zerop extra)
+	       (inst srwi result result
+		     (logxor (* extra ,bits) ,(1- elements-per-word))))
+	     (unless (= extra ,(1- elements-per-word))
+	       (inst andi. result result ,(1- (ash 1 bits)))))))
+       (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) :target shift)
+		(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 offset)
+	 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
+	 (:generator 25
+	   (inst srwi offset index ,bit-shift)
+	   (inst slwi offset offset 2)
+	   (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes)
+			               vm:other-pointer-type))
+	   (inst lwzx old object offset)
+	   (inst andi. shift index ,(1- elements-per-word))
+	   (inst xori shift shift ,(1- elements-per-word))
+	   ,@(unless (= bits 1)
+	       `((inst slwi shift shift ,(1- (integer-length bits)))))
+	   (unless (and (sc-is value immediate)
+			(= (tn-value value) ,(1- (ash 1 bits))))
+	     (inst lr temp ,(1- (ash 1 bits)))
+	     (inst slw temp temp shift)
+	     (inst not temp temp)
+	     (inst and old old temp))
+	   (unless (sc-is value zero)
+	     (sc-case value
+	       (immediate
+		(inst lr temp (logand (tn-value value) ,(1- (ash 1 bits)))))
+	       (unsigned-reg
+		(inst andi. temp value ,(1- (ash 1 bits)))))
+	     (inst slw temp temp shift)
+	     (inst or old old temp))
+	   (inst stwx old object offset)
+	   (sc-case value
+	     (immediate
+	      (inst lr result (tn-value value)))
+	     (t
+	      (move result value)))))
+       (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)) offset-reg temp old)
+	 (:generator 20
+	   (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 16))
+		      (inst lwz old object offset))
+		     (t
+		      (inst lr offset-reg offset)
+		      (inst lwzx old object offset-reg)))
+	       (unless (and (sc-is value immediate)
+			    (= (tn-value value) ,(1- (ash 1 bits))))
+		 (cond ((zerop extra)
+			(inst slwi old old ,bits)
+			(inst srwi old old ,bits))
+		       (t
+			(inst lr temp
+			      (lognot (ash ,(1- (ash 1 bits))
+					   (* (logxor extra
+						      ,(1- elements-per-word))
+					      ,bits))))
+			(inst and old old temp))))
+	       (sc-case value
+		 (zero)
+		 (immediate
+		  (let ((value (ash (logand (tn-value value)
+					    ,(1- (ash 1 bits)))
+				    (* (logxor extra
+					       ,(1- elements-per-word))
+				       ,bits))))
+		    (cond ((typep value '(unsigned-byte 16))
+			   (inst ori old old value))
+			  (t
+			   (inst lr temp value)
+			   (inst or old old temp)))))
+		 (unsigned-reg
+		  (inst slwi temp value
+			(* (logxor extra ,(1- elements-per-word)) ,bits))
+		  (inst or old old temp)))
+	       (if (typep offset '(signed-byte 16))
+		   (inst stw old object offset)
+		   (inst stwx old object offset-reg)))
+	     (sc-case value
+	       (immediate
+		(inst lr result (tn-value value)))
+	       (t
+		(move result value)))))))))
+
+); eval-when (:compile-toplevel :execute)
+
+(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))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-single-float positive-fixnum)
+  (:results (value :scs (single-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:result-types single-float)
+  (:generator 5
+    (inst addi offset index (- (* vm:vector-data-offset vm:word-bytes)
+			      vm:other-pointer-type))
+    (inst lfsx value object offset)))
+
+
+(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))
+	 (index :scs (any-reg))
+	 (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)) offset)
+  (:generator 5
+    (inst addi offset index
+	  (- (* vm:vector-data-offset vm:word-bytes)
+	     vm:other-pointer-type))
+    (inst stfsx value object offset)
+    (unless (location= result value)
+      (inst frsp result value))))
+
+(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))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-double-float positive-fixnum)
+  (:results (value :scs (double-reg)))
+  (:result-types double-float)
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:generator 7
+    (inst slwi offset index 1)
+    (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))
+    (inst lfdx value object offset)))
+
+(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))
+	 (index :scs (any-reg))
+	 (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)) offset)
+  (:generator 20
+    (inst slwi offset index 1)
+    (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))
+    (inst stfdx value object offset)
+    (unless (location= result value)
+      (inst fmr result value))))
+
+;;; These VOPs are used for implementing float slots in structures (whose raw
+;;; data is an unsigned-32 vector.
+;;;
+(define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
+  (:translate %raw-ref-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-single data-vector-set/simple-array-single-float)
+  (:translate %raw-set-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
+;;;
+(define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
+  (:translate %raw-ref-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-double data-vector-set/simple-array-double-float)
+  (:translate %raw-set-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
+
+
+;;; These vops are useful for accessing the bits of a vector irrespective of
+;;; what type of vector it is.
+;;; 
+
+(define-vop (raw-bits word-index-ref)
+  (:note "raw-bits VOP")
+  (:translate %raw-bits)
+  (:results (value :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:variant 0 vm:other-pointer-type))
+
+(define-vop (set-raw-bits word-index-set)
+  (:note "setf raw-bits VOP")
+  (:translate %set-raw-bits)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg zero immediate))
+	 (value :scs (unsigned-reg)))
+  (:arg-types * positive-fixnum unsigned-num)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:variant 0 vm:other-pointer-type))
+
+
+
+;;;; Misc. Array VOPs.
+
+
+#+nil
+(define-vop (vector-word-length)
+  (:args (vec :scs (descriptor-reg)))
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 6
+    (loadw res vec clc::g-vector-header-words)
+    (inst niuo res res clc::g-vector-words-mask-16)))
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
+
+
+;;;
+#+signed-array
+(define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
+  (:note "inline array access")
+  (:variant vm:vector-data-offset vm:other-pointer-type)
+  (:translate data-vector-ref)
+  (:arg-types simple-array-signed-byte-8 positive-fixnum)
+  (:results (value :scs (signed-reg)))
+  (:result-types tagged-num))
+#+signed-array
+(define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set)
+  (:note "inline array store")
+  (:variant vm:vector-data-offset vm:other-pointer-type)
+  (:translate data-vector-set)
+  (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg zero immediate))
+	 (value :scs (signed-reg)))
+  (:results (result :scs (signed-reg)))
+  (:result-types tagged-num))
+
+#+signed-array
+(define-vop (data-vector-ref/simple-array-signed-byte-16
+	     signed-halfword-index-ref)
+  (:note "inline array access")
+  (:variant vm:vector-data-offset vm:other-pointer-type)
+  (:translate data-vector-ref)
+  (:arg-types simple-array-signed-byte-16 positive-fixnum)
+  (:results (value :scs (signed-reg)))
+  (:result-types tagged-num))
+#+signed-array
+(define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set)
+  (:note "inline array store")
+  (:variant vm:vector-data-offset vm:other-pointer-type)
+  (:translate data-vector-set)
+  (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg zero immediate))
+	 (value :scs (signed-reg)))
+  (:results (result :scs (signed-reg)))
+  (:result-types tagged-num))
+
diff --git a/compiler/ppc/c-call.lisp b/compiler/ppc/c-call.lisp
new file mode 100644
index 000000000..79026d593
--- /dev/null
+++ b/compiler/ppc/c-call.lisp
@@ -0,0 +1,179 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/c-call.lisp,v 1.1 2001/02/11 14:22:04 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and other necessary machine specific support
+;;; routines for call-out to C.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "PPC")
+
+(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
+  (gpr-args 0)
+  (fpr-args 0)
+  ;SVR4 [a]abi wants two words on stack (callee saved lr, backpointer).
+  (stack-frame-size 2))
+
+(defun int-arg (state prim-type reg-sc stack-sc)
+  (let ((reg-args (arg-state-gpr-args state)))
+    (cond ((< reg-args 8)
+	   (setf (arg-state-gpr-args state) (1+ reg-args))
+	   (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
+	  (t
+	   (let ((frame-size (arg-state-stack-frame-size state)))
+	     (setf (arg-state-stack-frame-size state) (1+ frame-size))
+	     (my-make-wired-tn prim-type stack-sc frame-size))))))
+
+(def-alien-type-method (integer :arg-tn) (type state)
+  (if (alien-integer-type-signed type)
+      (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
+      (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
+
+(def-alien-type-method (system-area-pointer :arg-tn) (type state)
+  (declare (ignore type))
+  (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
+
+; If a single-float arg has to go on the stack, it's promoted to
+; double.  That way, C programs can get subtle rounding errors
+; when unrelated arguments are introduced.
+
+(def-alien-type-method (single-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let* ((fprs (arg-state-fpr-args state)))
+    (cond ((< fprs 8)
+	   (incf (arg-state-fpr-args state))
+	   ; Assign outgoing FPRs starting at FP1
+	   (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
+	  (t
+	   (let* ((stack-offset (arg-state-stack-frame-size state)))
+	     (if (oddp stack-offset)
+	       (incf stack-offset))
+	     (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
+	     (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
+
+(def-alien-type-method (double-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let* ((fprs (arg-state-fpr-args state)))
+    (cond ((< fprs 8)
+	   (incf (arg-state-fpr-args state))
+	   ; Assign outgoing FPRs starting at FP1
+	   (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
+	  (t
+	   (let* ((stack-offset (arg-state-stack-frame-size state)))
+	     (if (oddp stack-offset)
+	       (incf stack-offset))
+	     (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
+	     (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
+	   
+(def-alien-type-method (integer :result-tn) (type)
+  (if (alien-integer-type-signed type)
+      (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)
+      (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)))
+
+
+(def-alien-type-method (system-area-pointer :result-tn) (type)
+  (declare (ignore type))
+  (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset))
+
+(def-alien-type-method (single-float :result-tn) (type)
+  (declare (ignore type))
+  (my-make-wired-tn 'single-float 'single-reg 1))
+
+(def-alien-type-method (double-float :result-tn) (type)
+  (declare (ignore type))
+  (my-make-wired-tn 'double-float 'double-reg 1))
+
+(def-alien-type-method (values :result-tn) (type)
+  (mapcar #'(lambda (type)
+	      (invoke-alien-type-method :result-tn type))
+	  (alien-values-type-values type)))
+
+
+(def-vm-support-routine make-call-out-tns (type)
+  (declare (type alien-function-type type))
+  (let ((arg-state (make-arg-state)))
+    (collect ((arg-tns))
+      (dolist (arg-type (alien-function-type-arg-types type))
+	(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+      (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
+	      (* (arg-state-stack-frame-size arg-state) word-bytes)
+	      (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 lr res  (make-fixup foreign-symbol :foreign))))
+
+(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 (: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 cfunc function)
+      (inst bla (make-fixup "call_into_c" :foreign))
+      (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
+    (unless (zerop amount)
+      (let ((delta (- (logandc2 (+ amount 8 7) 7))))
+	(cond ((>= delta (ash -1 16))
+	       (inst stwu nsp-tn nsp-tn delta))
+	      (t
+	       (inst lr temp delta)
+	       (inst stwux  nsp-tn nsp-tn temp)))))
+    (unless (location= result nsp-tn)
+      ;; They are only location= when the result tn was allocated by
+      ;; make-call-out-tns above, which takes the number-stack-displacement
+      ;; into account itself.
+      (inst addi result nsp-tn number-stack-displacement))))
+
+(define-vop (dealloc-number-stack-space)
+  (:info amount)
+  (:policy :fast-safe)
+  (:generator 0
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 8 7) 7)))
+	(cond ((< delta (ash 1 16))
+	       (inst addi nsp-tn nsp-tn delta))
+	      (t
+	       (inst lwz nsp-tn nsp-tn 0)))))))
diff --git a/compiler/ppc/call.lisp b/compiler/ppc/call.lisp
new file mode 100644
index 000000000..05259e074
--- /dev/null
+++ b/compiler/ppc/call.lisp
@@ -0,0 +1,1269 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/call.lisp,v 1.1 2001/02/11 14:22:04 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of function call for the PPC.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "PPC")
+
+
+;;;; 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
+;;; frame.  Non-descriptor stack frames must be multiples of 16 bytes under
+;;; the PPC SVr4 ABI (though the EABI may be less restrictive.)  Two words
+;;; are reserved for the stack backlink and saved LR (see PPC::NUMBER-STACK-
+;;; DISPLACEMENT.)
+;;;
+;;; Duh.  PPC Linux (and VxWorks) adhere to the EABI.
+(defun bytes-needed-for-non-descriptor-stack-frame ()
+  (logandc2 (+ 7 number-stack-displacement
+	       (* (sb-allocated-size 'non-descriptor-stack) vm:word-bytes))
+	    7))
+
+
+;;; Used for setting up the Old-FP in local call.
+;;;
+(define-vop (current-fp)
+  (:results (val :scs (any-reg)))
+  (:generator 1
+    (move val cfp-tn)))
+
+;;; 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 val nfp (bytes-needed-for-non-descriptor-stack-frame))))))
+
+
+(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 vm:lowtag-bits)
+    (trace-table-entry trace-table-function-prologue)
+    (emit-label start-lab)
+    (let* ((entry-label (gen-label)))
+      ;; Allocate function header.
+      (inst function-header-word)
+      (inst b entry-label)
+      (dotimes (i (1- (1- vm:function-code-offset)))
+	(inst word 0))
+      (emit-label entry-label))
+    ;; The start of the actual code.
+    ;; Fix CODE, cause the function object was passed in.
+    (inst compute-code-from-fn code-tn code-tn start-lab temp)
+    ;; Build our stack frames.
+    (inst addi csp-tn cfp-tn
+	  (* vm:word-bytes (sb-allocated-size 'control-stack)))
+    (let ((nfp-tn (current-nfp-tn vop)))
+      (when nfp-tn
+	(let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame)))
+	  (when (> nbytes number-stack-displacement)
+	    (inst stwu nsp-tn nsp-tn (- nbytes))
+	    (inst addi nfp-tn nsp-tn number-stack-displacement)))))
+    (trace-table-entry trace-table-normal)))
+
+(define-vop (allocate-frame)
+  (:results (res :scs (any-reg))
+	    (nfp :scs (any-reg)))
+  (:info callee)
+  (:generator 2
+    (trace-table-entry trace-table-function-prologue)
+    (move res csp-tn)
+    (inst addi csp-tn csp-tn
+	  (* vm:word-bytes (sb-allocated-size 'control-stack)))
+    (when (ir2-environment-number-stack-p callee)
+      (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame)))
+	(when (> nbytes number-stack-displacement)
+	  (inst stwu nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame)))
+	  (inst addi nfp nsp-tn number-stack-displacement))))
+    (trace-table-entry trace-table-normal)))
+
+;;; 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 res csp-tn)
+      (inst addi csp-tn csp-tn (* nargs vm:word-bytes)))))
+
+
+
+
+;;; 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
+;;;     callee 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
+	subcc temp nargs register-arg-count
+
+	b :lt default-value-7	; jump to default code
+	loadw move-temp ocfp-tn 6	; Move value to correct location.
+        subcc temp 1
+	store-stack-tn val4-tn move-temp
+
+	b :lt default-value-8
+	loadw move-temp ocfp-tn 7
+        subcc temp 1
+	store-stack-tn val5-tn move-temp
+
+	...
+
+defaulting-done
+	move csp ocfp			; 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))
+  (if (<= nvals 1)
+      (progn
+	(new-assem:without-scheduling ()
+	  (note-this-location vop :single-value-return)
+	  (move csp-tn ocfp-tn)
+	  (inst nop))
+	(inst compute-code-from-lra code-tn code-tn lra-label temp))
+      (let ((regs-defaulted (gen-label))
+	    (defaulting-done (gen-label))
+	    (default-stack-vals (gen-label)))
+	;; Branch off to the MV case.
+	(new-assem:without-scheduling ()
+	  (note-this-location vop :unknown-return)
+	  (if (> nvals register-arg-count)
+	      (inst addic. temp nargs-tn (- (fixnum register-arg-count)))
+	      (move csp-tn ocfp-tn))
+	  (inst b regs-defaulted))
+	
+	;; Do the single value calse.
+	(do ((i 1 (1+ i))
+	     (val (tn-ref-across values) (tn-ref-across val)))
+	    ((= i (min nvals register-arg-count)))
+	  (move (tn-ref-tn val) null-tn))
+	(when (> nvals register-arg-count)
+	  (move ocfp-tn csp-tn)
+	  (inst b default-stack-vals))
+	
+	(emit-label regs-defaulted)
+	(when (> nvals register-arg-count)
+	  (collect ((defaults))
+	    (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 lwz move-temp ocfp-tn (* i vm:word-bytes))
+		(inst ble default-lab)
+		(inst addic. temp temp (- (fixnum 1)))
+		(store-stack-tn tn move-temp)))
+	    
+	    (emit-label defaulting-done)
+	    (move csp-tn ocfp-tn)
+	    
+	    (let ((defaults (defaults)))
+	      (when defaults
+		(assemble (*elsewhere*)
+		  (emit-label default-stack-vals)
+		  (trace-table-entry trace-table-function-prologue)
+		  (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))))))
+
+	(inst compute-code-from-lra code-tn code-tn lra-label temp)))
+  (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))
+  (let ((variable-values (gen-label))
+	(done (gen-label)))
+    (new-assem:without-scheduling ()
+      (inst b variable-values)
+      (inst nop))
+    
+    (inst compute-code-from-lra code-tn code-tn lra-label temp)
+    (inst addi csp-tn csp-tn 4)
+    (storew (first register-arg-tns) csp-tn -1)
+    (inst subi start csp-tn 4)
+    (inst li count (fixnum 1))
+    
+    (emit-label done)
+    
+    (assemble (*elsewhere*)
+      (trace-table-entry trace-table-function-prologue)
+      (emit-label variable-values)
+      (inst compute-code-from-lra code-tn code-tn lra-label temp)
+      (do ((arg register-arg-tns (rest arg))
+	   (i 0 (1+ i)))
+	  ((null arg))
+	(storew (first arg) args i))
+      (move start args)
+      (move count nargs)
+      (inst b done)
+      (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 (fp)
+	 (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 0)) 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 0)) 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
+	  (maybe-load-stack-tn callee-nfp nfp)))
+      (maybe-load-stack-tn cfp-tn fp)
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label temp)
+      (note-this-location vop :call-site)
+      (inst b target)
+      (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 (fp)
+	 (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
+	  (maybe-load-stack-tn callee-nfp nfp)))
+      (maybe-load-stack-tn cfp-tn fp)
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label temp)
+      (note-this-location vop :call-site)
+      (inst b target)
+      (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 (fp)
+	 (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
+	  (maybe-load-stack-tn callee-nfp nfp)))
+      (maybe-load-stack-tn cfp-tn fp)
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label temp)
+      (note-this-location vop :call-site)
+      (inst b target)
+      (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)
+  (: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 csp-tn cfp-tn)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addi nsp-tn cur-nfp 
+	      (- (bytes-needed-for-non-descriptor-stack-frame)
+		 number-stack-displacement))))
+    (move cfp-tn old-fp-temp)
+    (inst j return-pc-temp (- vm:word-bytes vm:other-pointer-type))
+    (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.
+;;;
+(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
+	   '(name :target name-pass)
+	   '(arg-fun :target lexenv))
+      
+      ,@(when (eq return :tail)
+	  '((old-fp :target old-fp-pass)
+	    (return-pc :target return-pc-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
+		  :from (:argument 1)
+		  ,@(unless (eq return :fixed)
+		      '(:to :eval)))
+		 old-fp-pass)
+
+     (:temporary (:sc descriptor-reg
+		  :offset lra-offset
+		  :from (:argument ,(if (eq return :tail) 2 1))
+		  :to :eval)
+		 return-pc-pass)
+
+     ,(if named
+	  `(:temporary (:sc descriptor-reg :offset cname-offset
+			    :from (:argument ,(if (eq return :tail) 0 1))
+			    :to :eval)
+		       name-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 0) :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)))
+
+     (: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
+	       (remove nil
+		       (list :load-nargs
+			     ,@(if (eq return :tail)
+				   '((unless (location= old-fp old-fp-pass)
+				       :load-old-fp)
+				     (unless (location= return-pc
+							return-pc-pass)
+				       :load-return-pc)
+				     (when cur-nfp
+				       :frob-nfp))
+				   '(:comp-lra
+				     (when cur-nfp
+				       :frob-nfp)
+				     :save-fp
+				     :load-fp))))))
+	 (flet ((do-next-filler ()
+		  (let* ((next (pop filler))
+			 (what (if (consp next) (car next) next)))
+		    (ecase what
+		      (:load-nargs
+		       ,@(if variable
+			     `((inst sub nargs-pass csp-tn new-fp)
+			       ,@(let ((index -1))
+				   (mapcar #'(lambda (name)
+					       `(loadw ,name new-fp
+						       ,(incf index)))
+					   register-arg-names)))
+			     '((inst lr nargs-pass (fixnum nargs)))))
+		      ,@(if (eq return :tail)
+			    '((:load-old-fp
+			       (sc-case old-fp
+				 (any-reg
+				  (inst mr old-fp-pass old-fp))
+				 (control-stack
+				  (loadw old-fp-pass cfp-tn
+					 (tn-offset old-fp)))))
+			      (:load-return-pc
+			       (sc-case return-pc
+				 (descriptor-reg
+				  (inst mr return-pc-pass return-pc))
+				 (control-stack
+				  (loadw return-pc-pass cfp-tn
+					 (tn-offset return-pc)))))
+			      (:frob-nfp
+			       (inst addi nsp-tn cur-nfp
+				     (- (bytes-needed-for-non-descriptor-stack-frame)
+					number-stack-displacement))))
+			    `((:comp-lra
+			       (inst compute-lra-from-code
+				     return-pc-pass code-tn lra-label temp))
+			      (:frob-nfp
+			       (store-stack-tn nfp-save cur-nfp))
+			      (:save-fp
+			       (inst mr old-fp-pass cfp-tn))
+			      (:load-fp
+			       ,(if variable
+				    '(move cfp-tn new-fp)
+				    '(if (> nargs register-arg-count)
+					 (move cfp-tn new-fp)
+					 (move cfp-tn csp-tn))))))
+		      ((nil))))))
+
+	   ,@(if named
+		 `((sc-case name
+		     (descriptor-reg (move name-pass name))
+		     (control-stack
+		      (loadw name-pass cfp-tn (tn-offset name))
+		      (do-next-filler))
+		     (constant
+		      (loadw name-pass code-tn (tn-offset name)
+			     vm:other-pointer-type)
+		      (do-next-filler)))
+		   (loadw function name-pass fdefn-raw-addr-slot
+			  other-pointer-type)
+		   (do-next-filler))
+		 `((sc-case arg-fun
+		     (descriptor-reg (move lexenv arg-fun))
+		     (control-stack
+		      (loadw lexenv cfp-tn (tn-offset arg-fun))
+		      (do-next-filler))
+		     (constant
+		      (loadw lexenv code-tn (tn-offset arg-fun)
+			     vm:other-pointer-type)
+		      (do-next-filler)))
+		   (loadw function lexenv vm:closure-function-slot
+			  vm:function-pointer-type)
+		   (do-next-filler)))
+	   (loop
+	     (if filler
+		 (do-next-filler)
+		 (return)))
+	   
+	   (note-this-location vop :call-site)
+	   (inst mtctr function)
+	   (inst mr code-tn function)
+	   (inst bctr)
+	   #|
+	   (inst j function
+		 (- (ash vm:function-code-offset vm:word-shift)
+		    vm:function-pointer-type))
+	   |#)
+
+	 ,@(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))))
+
+
+(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)
+
+
+  (:vop-var vop)
+
+  (:generator 75
+
+    ;; Move these into the passing locations if they are not already there.
+    (move args args-arg)
+    (move lexenv function-arg)
+    (move old-fp old-fp-arg)
+    (move lra lra-arg)
+
+
+    ;; Clear the number stack if anything is there.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addi nsp-tn cur-nfp
+	      (- (bytes-needed-for-non-descriptor-stack-frame)
+		 number-stack-displacement))))
+
+   
+    (inst ba (make-fixup 'tail-call-variable :assembly-routine))))
+
+
+;;;; 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
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Clear the number stack.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addi nsp-tn cur-nfp
+	      (- (bytes-needed-for-non-descriptor-stack-frame)
+		 number-stack-displacement))))
+    ;; Clear the control stack, and restore the frame pointer.
+    (move csp-tn cfp-tn)
+    (move cfp-tn old-fp)
+    ;; Out of here.
+    (lisp-return return-pc :offset 2)
+    (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 any-reg :offset nargs-offset) nargs)
+  (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
+  (:vop-var vop)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Clear the number stack.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addi nsp-tn cur-nfp
+	      (- (bytes-needed-for-non-descriptor-stack-frame)
+		 number-stack-displacement))))
+    (cond ((= nvals 1)
+	   ;; Clear the control stack, and restore the frame pointer.
+	   (move csp-tn cfp-tn)
+	   (move cfp-tn old-fp)
+	   ;; Out of here.
+	   (lisp-return return-pc :offset 2))
+	  (t
+	   ;; Establish the values pointer and values count.
+	   (move val-ptr cfp-tn)
+	   (inst lr nargs (fixnum nvals))
+	   ;; restore the frame pointer and clear as much of the control
+	   ;; stack as possible.
+	   (move cfp-tn old-fp)
+	   (inst addi csp-tn val-ptr (* nvals word-bytes))
+	   ;; pre-default any argument register that need it.
+	   (when (< nvals register-arg-count)
+	     (dolist (reg (subseq (list a0 a1 a2 a3) nvals))
+	       (move reg null-tn)))
+	   ;; 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)
+
+
+  (:vop-var vop)
+
+  (:generator 13
+    (trace-table-entry trace-table-function-epilogue)
+    (let ((not-single (gen-label)))
+      ;; Clear the number stack.
+      (let ((cur-nfp (current-nfp-tn vop)))
+	(when cur-nfp
+	  (inst addi nsp-tn cur-nfp
+		(- (bytes-needed-for-non-descriptor-stack-frame)
+		   number-stack-displacement))))
+
+      ;; Check for the single case.
+      (inst cmpwi nvals-arg (fixnum 1))
+      (inst lwz a0 vals-arg 0)
+      (inst bne not-single)
+
+      ;; Return with one value.
+      (move csp-tn cfp-tn)
+      (move cfp-tn old-fp-arg)
+      (lisp-return lra-arg :offset 2)
+		
+      ;; Nope, not the single case.
+      (emit-label not-single)
+      (move old-fp old-fp-arg)
+      (move lra lra-arg)
+      (move vals vals-arg)
+      (move nvals nvals-arg)
+      (inst ba (make-fixup 'return-multiple :assembly-routine)))
+    (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 closure lexenv)))
+
+;;; 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
+    (let ((loop (gen-label))
+	  (do-regs (gen-label))
+	  (done (gen-label)))
+      (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 result csp-tn))
+      ;; Allocate the space on the stack.
+      (cond ((zerop fixed)
+	     (inst cmpwi nargs-tn 0)
+	     (inst add csp-tn csp-tn nargs-tn)
+	     (inst beq done))
+	    (t
+	     (inst addic. count nargs-tn (- (fixnum fixed)))
+	     (inst ble done)
+	     (inst add csp-tn csp-tn count)))
+      (when (< fixed register-arg-count)
+	;; We must stop when we run out of stack args, not when we run out of
+	;; more args.
+	(inst addic. count nargs-tn (- (fixnum register-arg-count)))
+	;; Everything of interest is in registers.
+	(inst ble do-regs))
+      ;; Initialize dst to be end of stack.
+      (move dst csp-tn)
+      ;; Initialize src to be end of args.
+      (inst add src cfp-tn nargs-tn)
+
+      (emit-label loop)
+      ;; *--dst = *--src, --count
+      (inst addi src src (- vm:word-bytes))
+      (inst addic. count count (- (fixnum 1)))
+      (loadw temp src)
+      (inst addi dst dst (- vm:word-bytes))
+      (storew temp dst)
+      (inst bgt loop)
+
+      (emit-label do-regs)
+      (when (< fixed register-arg-count)
+	;; Now we have to deposit any more args that showed up in registers.
+	(inst subic. count nargs-tn (fixnum fixed))
+	(do ((i fixed (1+ i)))
+	    ((>= i register-arg-count))
+	  ;; Don't deposit any more than there are.
+	  (inst beq done)
+	  (inst subic. count count (fixnum 1))
+	  ;; Store it relative to the pointer saved at the start.
+	  (storew (nth i register-arg-tns) result (- i fixed))))
+      (emit-label 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-vop (more-arg word-index-ref)
+  (:variant 0 0)
+  (:translate %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)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:results (result :scs (descriptor-reg)))
+  (:translate %listify-rest-args)
+  (:policy :safe)
+  (:generator 20
+    (move context context-arg)
+    (move count count-arg)
+    ;; Check to see if there are any arguments.
+    (inst cmpwi count 0)
+    (move result null-tn)
+    (inst beq done)
+
+    ;; We need to do this atomically.
+    (pseudo-atomic (pa-flag)
+      (assemble ()
+	;; Allocate a cons (2 words) for each item.
+	(inst clrrwi result alloc-tn lowtag-bits)
+	(inst ori result result list-pointer-type)
+	(move dst result)
+	(inst slwi temp count 1)
+	(inst add alloc-tn alloc-tn temp)
+	(inst b enter)
+
+	;; Compute the next cons and store it in the current one.
+	LOOP
+	(inst addi dst dst (* 2 vm:word-bytes))
+	(storew dst dst -1 vm:list-pointer-type)
+
+	;; Grab one value.
+	ENTER
+	(loadw temp context)
+	(inst addi context context vm:word-bytes)
+
+	;; Dec count, and if != zero, go back for more.
+	(inst addic. count count (- (fixnum 1)))
+	;; Store the value into the car of the current cons (in the delay
+	;; slot).
+	(storew temp dst 0 vm:list-pointer-type)
+	(inst bgt loop)
+
+
+	;; NIL out the last cons.
+	(storew null-tn dst 1 vm:list-pointer-type)))
+    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)
+  (:policy :fast-safe)
+  (:translate c::%more-arg-context)
+  (:args (supplied :scs (any-reg)))
+  (:arg-types tagged-num (:constant fixnum))
+  (:info fixed)
+  (:results (context :scs (descriptor-reg))
+	    (count :scs (any-reg)))
+  (:result-types t tagged-num)
+  (:note "more-arg-context")
+  (:generator 5
+    (inst subi count supplied (fixnum fixed))
+    (inst sub context csp-tn count)))
+
+
+;;; Signal wrong argument count error if Nargs isn't = to Count.
+;;;
+#|
+(define-vop (verify-argument-count)
+  (:policy :fast-safe)
+  (:translate c::%verify-argument-count)
+  (:args (nargs :scs (any-reg)))
+  (:arg-types positive-fixnum (:constant t))
+  (:info count)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (let ((err-lab
+	   (generate-error-code vop invalid-argument-count-error nargs)))
+      (inst cmpwi nargs (fixnum count))
+      (inst bne err-lab))))
+|#
+(define-vop (verify-argument-count)
+  (:policy :fast-safe)
+  (:translate c::%verify-argument-count)
+  (:args (nargs :scs (any-reg)))
+  (:arg-types positive-fixnum (:constant t))
+  (:info count)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+   (inst twi :ne nargs (fixnum count))))
+
+
+;;; Signal various errors.
+;;;
+(macrolet ((frob (name error translate &rest args)
+	     `(define-vop (,name)
+		,@(when translate
+		    `((:policy :fast-safe)
+		      (:translate ,translate)))
+		(: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
+    c::%argument-count-error nargs)
+  (frob type-check-error object-not-type-error c::%type-check-error
+    object type)
+  (frob layout-invalid-error layout-invalid-error c::%layout-invalid-error
+    object layout)
+  (frob odd-keyword-arguments-error odd-keyword-arguments-error
+    c::%odd-keyword-arguments-error)
+  (frob unknown-keyword-argument-error unknown-keyword-argument-error
+    c::%unknown-keyword-argument-error key)
+  (frob nil-function-returned-error nil-function-returned-error nil fun))
diff --git a/compiler/ppc/cell.lisp b/compiler/ppc/cell.lisp
new file mode 100644
index 000000000..2595f5a40
--- /dev/null
+++ b/compiler/ppc/cell.lisp
@@ -0,0 +1,290 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/cell.lisp,v 1.1 2001/02/11 14:22:04 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of various primitive memory access
+;;; VOPs for the PPC.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by William Lott.
+;;; 
+
+(in-package "PPC")
+
+
+;;;; Data object ref/set stuff.
+
+(define-vop (slot)
+  (:args (object :scs (descriptor-reg)))
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:generator 1
+    (loadw result object offset lowtag)))
+
+(define-vop (set-slot)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg)))
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results)
+  (:generator 1
+    (storew value object offset lowtag)))
+
+
+
+;;;; Symbol hacking VOPs:
+
+;;; The compiler likes to be able to directly SET symbols.
+;;;
+(define-vop (set cell-set)
+  (:variant symbol-value-slot other-pointer-type))
+
+;;; 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 (: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 obj-temp object)
+    (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type)
+    (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
+      (inst cmpwi value vm:unbound-marker-type)
+      (inst beq 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))
+
+(define-vop (boundp boundp-frob)
+  (:translate boundp)
+  (:generator 9
+    (loadw value object vm:symbol-value-slot vm:other-pointer-type)
+    (inst cmpwi value vm:unbound-marker-type)
+    (inst b? (if not-p :eq :ne) target)))
+
+(define-vop (fast-symbol-value cell-ref)
+  (:variant vm:symbol-value-slot vm:other-pointer-type)
+  (:policy :fast)
+  (:translate symbol-value))
+
+
+;;;; Fdefinition (fdefn) objects.
+
+(define-vop (fdefn-function cell-ref)
+  (:variant fdefn-function-slot other-pointer-type))
+
+(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)
+    (inst cmpw value null-tn)
+    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
+      (inst beq 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
+    (let ((normal-fn (gen-label)))
+      (load-type type function (- function-pointer-type))
+      (inst cmpwi type function-header-type)
+      (inst mr lip function)
+      (inst beq normal-fn)
+      (inst lr lip  (make-fixup "closure_tramp" :foreign))
+      (emit-label normal-fn)
+      (storew function fdefn fdefn-function-slot other-pointer-type)
+      (storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
+      (move result function))))
+
+(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 lr temp  (make-fixup "undefined_tramp" :foreign))
+    (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move result fdefn)))
+
+
+
+;;;; 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 vm:symbol-value-slot vm:other-pointer-type)
+    (inst addi bsp-tn bsp-tn (* 2 vm:word-bytes))
+    (storew temp bsp-tn (- vm:binding-value-slot vm:binding-size))
+    (storew symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size))
+    (storew val symbol vm:symbol-value-slot vm:other-pointer-type)))
+
+
+(define-vop (unbind)
+  (:temporary (:scs (descriptor-reg)) symbol value)
+  (:generator 0
+    (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size))
+    (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size))
+    (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
+    (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size))
+    (inst subi bsp-tn bsp-tn (* 2 vm:word-bytes))))
+
+
+(define-vop (unbind-to-here)
+  (:args (arg :scs (descriptor-reg any-reg) :target where))
+  (:temporary (:scs (any-reg) :from (:argument 0)) where)
+  (:temporary (:scs (descriptor-reg)) symbol value)
+  (:generator 0
+    (let ((loop (gen-label))
+	  (skip (gen-label))
+	  (done (gen-label)))
+      (move where arg)
+      (inst cmpw where bsp-tn)
+      (inst beq done)
+
+      (emit-label loop)
+      (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size))
+      (inst cmpwi symbol 0)
+      (inst beq skip)
+      (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size))
+      (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
+      (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size))
+
+      (emit-label skip)
+      (inst subi bsp-tn bsp-tn (* 2 vm:word-bytes))
+      (inst cmpw where bsp-tn)
+      (inst bne loop)
+
+      (emit-label done))))
+
+
+
+;;;; Closure indexing.
+
+(define-vop (closure-index-ref word-index-ref)
+  (:variant vm:closure-info-offset vm:function-pointer-type)
+  (:translate %closure-index-ref))
+
+(define-vop (funcallable-instance-info word-index-ref)
+  (:variant funcallable-instance-info-offset vm:function-pointer-type)
+  (:translate %funcallable-instance-info))
+
+(define-vop (set-funcallable-instance-info word-index-set)
+  (:variant funcallable-instance-info-offset function-pointer-type)
+  (:translate %set-funcallable-instance-info))
+
+(define-vop (funcallable-instance-lexenv cell-ref)
+  (:variant funcallable-instance-lexenv-slot function-pointer-type))
+
+
+(define-vop (closure-ref slot-ref)
+  (:variant closure-info-offset function-pointer-type))
+
+(define-vop (closure-init slot-set)
+  (:variant closure-info-offset function-pointer-type))
+
+
+;;;; Value Cell hackery.
+
+(define-vop (value-cell-ref cell-ref)
+  (:variant value-cell-value-slot other-pointer-type))
+
+(define-vop (value-cell-set cell-set)
+  (:variant value-cell-value-slot other-pointer-type))
+
+
+
+;;;; Instance hackery:
+
+(define-vop (instance-length)
+  (:policy :fast-safe)
+  (:translate %instance-length)
+  (:args (struct :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (loadw temp struct 0 instance-pointer-type)
+    (inst srwi res temp vm:type-bits)))
+
+(define-vop (instance-ref slot-ref)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:policy :fast-safe)
+  (:translate %instance-ref)
+  (:arg-types instance (:constant index)))
+
+(define-vop (instance-set slot-set)
+  (:policy :fast-safe)
+  (:translate %instance-set)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance (:constant index) *))
+
+(define-vop (instance-index-ref word-index-ref)
+  (:policy :fast-safe) 
+  (:translate %instance-ref)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance positive-fixnum))
+
+(define-vop (instance-index-set word-index-set)
+  (:policy :fast-safe) 
+  (:translate %instance-set)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance positive-fixnum *))
+
+
+
+;;;; Code object frobbing.
+
+(define-vop (code-header-ref word-index-ref)
+  (:translate code-header-ref)
+  (:policy :fast-safe)
+  (:variant 0 other-pointer-type))
+
+(define-vop (code-header-set word-index-set)
+  (:translate code-header-set)
+  (:policy :fast-safe)
+  (:variant 0 other-pointer-type))
+
diff --git a/compiler/ppc/char.lisp b/compiler/ppc/char.lisp
new file mode 100644
index 000000000..7dce4cb31
--- /dev/null
+++ b/compiler/ppc/char.lisp
@@ -0,0 +1,147 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/char.lisp,v 1.1 2001/02/11 14:22:04 dtc Rel $")
+;;;
+;;; **********************************************************************
+;;; 
+;;; This file contains the SPARC VM definition of character operations.
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted for the MIPS R2000 by Christopher Hoover.
+;;; And then to the SPARC by William Lott.
+;;;
+(in-package "PPC")
+
+
+
+;;;; 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)))
+  (:note "character untagging")
+  (:generator 1
+    (inst srwi y x vm:type-bits)))
+;;;
+(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)))
+  (:note "character tagging")
+  (:generator 1
+    (inst slwi y x vm:type-bits)
+    (inst ori y y vm:base-char-type)))
+;;;
+(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))))
+  (:note "character move")
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+;;;
+(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))
+  (:note "character arg move")
+  (:generator 0
+    (sc-case y
+      (base-char-reg
+       (move y x))
+      (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 (any-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+    (inst slwi res ch 2)))
+
+(define-vop (code-char)
+  (:translate code-char)
+  (:policy :fast-safe)
+  (:args (code :scs (any-reg) :target res))
+  (:arg-types positive-fixnum)
+  (:results (res :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 1
+    (inst srwi res code 2)))
+
+
+;;; 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 condition not-condition)
+  (:generator 3
+    (inst cmplw x y)
+    (inst b? (if not-p not-condition condition) target)))
+
+(define-vop (fast-char=/base-char base-char-compare)
+  (:translate char=)
+  (:variant :eq :ne))
+
+(define-vop (fast-char</base-char base-char-compare)
+  (:translate char<)
+  (:variant :lt :ge))
+
+(define-vop (fast-char>/base-char base-char-compare)
+  (:translate char>)
+  (:variant :gt :le))
+
diff --git a/compiler/ppc/debug.lisp b/compiler/ppc/debug.lisp
new file mode 100644
index 000000000..93ed335d0
--- /dev/null
+++ b/compiler/ppc/debug.lisp
@@ -0,0 +1,128 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/debug.lisp,v 1.1 2001/02/11 14:22:04 dtc Rel $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Compiler support for the new whizzy debugger.
+;;;
+;;; Written by William Lott.
+;;; 
+(in-package "PPC")
+
+(defknown di::current-sp () system-area-pointer (movable flushable))
+(defknown di::current-fp () system-area-pointer (movable flushable))
+(defknown di::stack-ref (system-area-pointer index) t (flushable))
+(defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe))
+(defknown di::lra-code-header (t) t (movable flushable))
+(defknown di::function-code-header (t) t (movable flushable))
+(defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
+(defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
+(defknown di::function-word-offset (function) index (movable flushable))
+
+(define-vop (debug-cur-sp)
+  (:translate di::current-sp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move res csp-tn)))
+
+(define-vop (debug-cur-fp)
+  (:translate di::current-fp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move res cfp-tn)))
+
+(define-vop (read-control-stack)
+  (:translate kernel:stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (any-reg)))
+  (:arg-types system-area-pointer positive-fixnum)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 5
+    (inst lwzx result sap offset)))
+
+(define-vop (write-control-stack)
+  (:translate kernel:%set-stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (any-reg))
+	 (value :scs (descriptor-reg) :target result))
+  (:arg-types system-area-pointer positive-fixnum *)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 5
+    (inst stwx value sap offset)
+    (move result value)))
+
+(define-vop (code-from-mumble)
+  (:policy :fast-safe)
+  (:args (thing :scs (descriptor-reg)))
+  (:results (code :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:variant-vars lowtag)
+  (:generator 5
+    (let ((bogus (gen-label))
+	  (done (gen-label)))
+      (loadw temp thing 0 lowtag)
+      (inst srwi temp temp vm:type-bits)
+      (inst cmpwi temp 0)
+      (inst slwi temp temp (1- (integer-length vm:word-bytes)))
+      (inst beq bogus)
+      (unless (= lowtag vm:other-pointer-type)
+	(inst addi temp temp (- lowtag vm:other-pointer-type)))
+      (inst sub code thing temp)
+      (emit-label done)
+      (assemble (*elsewhere*)
+	(emit-label bogus)
+	(move code null-tn)
+	(inst b done)))))
+
+(define-vop (code-from-lra code-from-mumble)
+  (:translate di::lra-code-header)
+  (:variant vm:other-pointer-type))
+
+(define-vop (code-from-function code-from-mumble)
+  (:translate di::function-code-header)
+  (:variant vm:function-pointer-type))
+
+(define-vop (make-lisp-obj)
+  (:policy :fast-safe)
+  (:translate di::make-lisp-obj)
+  (:args (value :scs (unsigned-reg) :target result))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 1
+    (move result value)))
+
+(define-vop (get-lisp-obj-address)
+  (:policy :fast-safe)
+  (:translate di::get-lisp-obj-address)
+  (:args (thing :scs (descriptor-reg) :target result))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move result thing)))
+
+
+(define-vop (function-word-offset)
+  (:policy :fast-safe)
+  (:translate di::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 srwi res res vm:type-bits)))
diff --git a/compiler/ppc/float.lisp b/compiler/ppc/float.lisp
new file mode 100644
index 000000000..eacc2d604
--- /dev/null
+++ b/compiler/ppc/float.lisp
@@ -0,0 +1,505 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/float.lisp,v 1.1 2001/02/11 14:22:04 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains floating point support for the PPC.
+;;;
+;;; Written by Rob MacLachlan
+;;; Sparc conversion by William Lott.
+;;;
+(in-package "PPC")
+
+
+;;;; Move functions:
+
+(define-move-function (load-single 1) (vop x y)
+  ((single-stack) (single-reg))
+  (inst lfs y (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes)))
+
+(define-move-function (store-single 1) (vop x y)
+  ((single-reg) (single-stack))
+  (inst stfs x (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)))
+
+
+(define-move-function (load-double 2) (vop x y)
+  ((double-stack) (double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (inst lfd y nfp offset)))
+
+(define-move-function (store-double 2) (vop x y)
+  ((double-reg) (double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (inst stfd x nfp offset)))
+
+
+
+;;;; Move VOPs:
+
+(macrolet ((frob (vop sc)
+	     `(progn
+		(define-vop (,vop)
+		  (:args (x :scs (,sc)
+			    :target y
+			    :load-if (not (location= x y))))
+		  (:results (y :scs (,sc)
+			       :load-if (not (location= x y))))
+		  (:note "float move")
+		  (:generator 0
+		    (unless (location= y x)
+                      (inst fmr y x))))
+		(define-move-vop ,vop :move (,sc) (,sc)))))
+  (frob single-move single-reg)
+  (frob double-move double-reg))
+
+
+(define-vop (move-from-float)
+  (:args (x :to :save))
+  (:results (y))
+  (:note "float to pointer coercion")
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:variant-vars double-p size type data)
+  (:generator 13
+    (with-fixed-allocation (y pa-flag ndescr type size))
+    (if double-p
+	(inst stfd x y (- (* data vm:word-bytes) vm:other-pointer-type))
+	(inst stfs x y (- (* data vm:word-bytes) vm:other-pointer-type)))))
+
+(macrolet ((frob (name sc &rest args)
+	     `(progn
+		(define-vop (,name move-from-float)
+		  (:args (x :scs (,sc) :to :save))
+		  (:results (y :scs (descriptor-reg)))
+		  (:variant ,@args))
+		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
+  (frob move-from-single single-reg
+    nil vm:single-float-size vm:single-float-type vm:single-float-value-slot)
+  (frob move-from-double double-reg
+    t vm:double-float-size vm:double-float-type vm:double-float-value-slot))
+
+(macrolet ((frob (name sc double-p value)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (descriptor-reg)))
+		  (:results (y :scs (,sc)))
+		  (:note "pointer to float coercion")
+		  (:generator 2
+		    (inst ,(if double-p 'lfd 'lfs) y x
+			  (- (* ,value vm:word-bytes) vm:other-pointer-type))))
+		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
+  (frob move-to-single single-reg nil vm:single-float-value-slot)
+  (frob move-to-double double-reg t vm:double-float-value-slot))
+
+
+(macrolet ((frob (name sc stack-sc double-p)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (,sc) :target y)
+			 (nfp :scs (any-reg)
+			      :load-if (not (sc-is y ,sc))))
+		  (:results (y))
+		  (:note "float argument move")
+		  (:generator ,(if double-p 2 1)
+		    (sc-case y
+		      (,sc
+		       (unless (location= x y)
+			 (inst fmr y x)))
+		      (,stack-sc
+		       (let ((offset (* (tn-offset y) vm:word-bytes)))
+			 (inst ,(if double-p 'stfd 'stfs) x nfp offset))))))
+		(define-move-vop ,name :move-argument
+		  (,sc descriptor-reg) (,sc)))))
+  (frob move-single-float-argument single-reg single-stack nil)
+  (frob move-double-float-argument double-reg double-stack t))
+
+
+(define-move-vop move-argument :move-argument
+  (single-reg double-reg) (descriptor-reg))
+
+
+;;;; Arithmetic VOPs:
+
+(define-vop (float-op)
+  (:args (x) (y))
+  (:results (r))
+  (:policy :fast-safe)
+  (:note "inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(macrolet ((frob (name sc ptype)
+	     `(define-vop (,name float-op)
+		(:args (x :scs (,sc))
+		       (y :scs (,sc)))
+		(:results (r :scs (,sc)))
+		(:arg-types ,ptype ,ptype)
+		(:result-types ,ptype))))
+  (frob single-float-op single-reg single-float)
+  (frob double-float-op double-reg double-float))
+
+(macrolet ((frob (op sinst sname scost dinst dname dcost)
+	     `(progn
+		(define-vop (,sname single-float-op)
+		  (:translate ,op)
+		  (:generator ,scost
+		    (inst ,sinst r x y)))
+		(define-vop (,dname double-float-op)
+		  (:translate ,op)
+		  (:generator ,dcost
+		    (inst ,dinst r x y))))))
+  (frob + fadds +/single-float 2 fadd +/double-float 2)
+  (frob - fsubs -/single-float 2 fsub -/double-float 2)
+  (frob * fmuls */single-float 4 fmul */double-float 5)
+  (frob / fdivs //single-float 12 fdiv //double-float 19))
+
+(macrolet ((frob (name inst translate sc type)
+	     `(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 ,inst y x)))))
+  (frob abs/single-float fabs abs single-reg single-float)
+  (frob abs/double-float fabs abs double-reg double-float)
+  (frob %negate/single-float fneg %negate single-reg single-float)
+  (frob %negate/double-float fneg %negate double-reg double-float))
+
+
+;;;; Comparison:
+
+(define-vop (float-compare)
+  (:args (x) (y))
+  (:conditional)
+  (:info target not-p)
+  (:variant-vars format yep nope)
+  (:policy :fast-safe)
+  (:note "inline float comparison")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (note-this-location vop :internal-error)
+    (ecase format
+      ((:single :double)
+       (inst fcmpo :cr1 x y)))
+    (inst b?  :cr1 (if not-p nope yep) target)))
+
+(macrolet ((frob (name sc ptype)
+	     `(define-vop (,name float-compare)
+		(:args (x :scs (,sc))
+		       (y :scs (,sc)))
+		(:arg-types ,ptype ,ptype))))
+  (frob single-float-compare single-reg single-float)
+  (frob double-float-compare double-reg double-float))
+
+(macrolet ((frob (translate yep nope sname dname)
+	     `(progn
+		(define-vop (,sname single-float-compare)
+		  (:translate ,translate)
+		  (:variant :single ,yep ,nope))
+		(define-vop (,dname double-float-compare)
+		  (:translate ,translate)
+		  (:variant :double ,yep ,nope)))))
+  (frob < :lt :ge </single-float </double-float)
+  (frob > :gt :le >/single-float >/double-float)
+  (frob = :eq :ne eql/single-float eql/double-float))
+
+
+;;;; Conversion:
+
+(macrolet ((frob (name translate inst to-sc to-type)
+	     `(define-vop (,name)
+		(:args (x :scs (signed-reg)))
+		(:temporary (:scs (double-stack)) temp)
+                (:temporary (:scs (double-reg)) fmagic)
+                (:temporary (:scs (signed-reg)) rtemp)
+		(:results (y :scs (,to-sc)))
+		(:arg-types signed-num)
+		(:result-types ,to-type)
+		(:policy :fast-safe)
+		(:note "inline float coercion")
+		(:translate ,translate)
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 5
+		  (let* ((stack-offset (* (tn-offset temp) vm:word-bytes))
+                         (nfp-tn (current-nfp-tn vop))
+                         (temp-offset-high (* stack-offset vm:word-bytes))
+                         (temp-offset-low (* (1+ stack-offset) vm:word-bytes)))
+                    (inst lis rtemp #x4330)   ; High word of magic constant
+                    (inst stw rtemp nfp-tn temp-offset-high)
+                    (inst lis rtemp #x8000)
+                    (inst stw rtemp nfp-tn temp-offset-low)
+                    (inst lfd fmagic nfp-tn temp-offset-high)
+                    (inst xor rtemp rtemp x)          ; invert sign bit of x : rtemp had #x80000000
+                    (inst stw rtemp nfp-tn temp-offset-low)
+                    (inst lfd y nfp-tn temp-offset-high) 		    
+		    (note-this-location vop :internal-error)
+		    (inst ,inst y y fmagic))))))
+  (frob %single-float/signed %single-float fsubs single-reg single-float)
+  (frob %double-float/signed %double-float fsub double-reg double-float))
+
+(macrolet ((frob (name translate inst 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 ,inst y x)))))
+  (frob %single-float/double-float %single-float frsp
+    double-reg double-float single-reg single-float)
+  (frob %double-float/single-float %double-float fmr
+    single-reg single-float double-reg double-float))
+
+(macrolet ((frob (trans from-sc from-type inst)
+	     `(define-vop (,(symbolicate trans "/" from-type))
+		(:args (x :scs (,from-sc) :target temp))
+		(:temporary (:from (:argument 0) :sc single-reg) temp)
+		(:temporary (:scs (double-stack)) stack-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 "inline float truncate")
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 5
+		  (note-this-location vop :internal-error)
+		  (inst ,inst temp x)
+		  (sc-case y
+		    (signed-stack
+		     (inst stfd temp (current-nfp-tn vop)
+			   (* (tn-offset y) vm:word-bytes)))
+		    (signed-reg
+		     (inst stfd temp (current-nfp-tn vop)
+			   (* (tn-offset stack-temp) vm:word-bytes))
+		     (inst lwz y (current-nfp-tn vop)
+			   (+ 4 (* (tn-offset stack-temp) vm:word-bytes)))))))))
+  (frob %unary-truncate single-reg single-float fctiwz)
+  (frob %unary-truncate double-reg double-float fctiwz)
+  (frob %unary-round single-reg single-float fctiw)
+  (frob %unary-round double-reg double-float fctiw))
+
+
+
+(define-vop (make-single-float)
+  (:args (bits :scs (signed-reg) :target res
+	       :load-if (not (sc-is bits signed-stack))))
+  (:results (res :scs (single-reg)
+		 :load-if (not (sc-is res single-stack))))
+  (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
+  (:temporary (:scs (signed-stack)) stack-temp)
+  (:arg-types signed-num)
+  (:result-types single-float)
+  (:translate make-single-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 4
+    (sc-case bits
+      (signed-reg
+       (sc-case res
+	 (single-reg
+	  (inst stw bits (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes))
+	  (inst lfs res (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes)))
+	 (single-stack
+	  (inst stw bits (current-nfp-tn vop)
+		(* (tn-offset res) vm:word-bytes)))))
+      (signed-stack
+       (sc-case res
+	 (single-reg
+	  (inst lfs res (current-nfp-tn vop)
+		(* (tn-offset bits) vm:word-bytes)))
+	 (single-stack
+	  (unless (location= bits res)
+	    (inst lwz temp (current-nfp-tn vop)
+		  (* (tn-offset bits) vm:word-bytes))
+	    (inst stw temp (current-nfp-tn vop)
+		  (* (tn-offset res) vm:word-bytes)))))))))
+
+(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))))
+  (:temporary (:scs (double-stack)) temp)
+  (:arg-types signed-num unsigned-num)
+  (:result-types double-float)
+  (:translate make-double-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 2
+    (let ((stack-tn (sc-case res
+		      (double-stack res)
+		      (double-reg temp))))
+      (inst stw hi-bits (current-nfp-tn vop)
+	    (* (tn-offset stack-tn) vm:word-bytes))
+      (inst stw lo-bits (current-nfp-tn vop)
+	    (* (1+ (tn-offset stack-tn)) vm:word-bytes)))
+    (when (sc-is res double-reg)
+      (inst lfd res (current-nfp-tn vop)
+	    (* (tn-offset temp) vm:word-bytes)))))
+
+(define-vop (single-float-bits)
+  (:args (float :scs (single-reg descriptor-reg)
+		:load-if (not (sc-is float single-stack))))
+  (:results (bits :scs (signed-reg)
+		  :load-if (or (sc-is float descriptor-reg single-stack)
+			       (not (sc-is bits signed-stack)))))
+  (:temporary (:scs (signed-stack)) stack-temp)
+  (:arg-types single-float)
+  (:result-types signed-num)
+  (:translate single-float-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 4
+    (sc-case bits
+      (signed-reg
+       (sc-case float
+	 (single-reg
+	  (inst stfs float (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes))
+	  (inst lwz bits (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes)))
+	 (single-stack
+	  (inst lwz bits (current-nfp-tn vop)
+		(* (tn-offset float) vm:word-bytes)))
+	 (descriptor-reg
+	  (loadw bits float vm:single-float-value-slot vm:other-pointer-type))))
+      (signed-stack
+       (sc-case float
+	 (single-reg
+	  (inst stfs float (current-nfp-tn vop)
+		(* (tn-offset bits) vm:word-bytes))))))))
+
+(define-vop (double-float-high-bits)
+  (:args (float :scs (double-reg descriptor-reg)
+		:load-if (not (sc-is float double-stack))))
+  (:results (hi-bits :scs (signed-reg)
+		     :load-if (or (sc-is float descriptor-reg double-stack)
+				  (not (sc-is hi-bits signed-stack)))))
+  (:temporary (:scs (signed-stack)) stack-temp)
+  (:arg-types double-float)
+  (:result-types signed-num)
+  (:translate double-float-high-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case hi-bits
+      (signed-reg
+       (sc-case float
+	 (double-reg
+	  (inst stfd float (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes))
+	  (inst lwz hi-bits (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes)))
+	 (double-stack
+	  (inst lwz hi-bits (current-nfp-tn vop)
+		(* (tn-offset float) vm:word-bytes)))
+	 (descriptor-reg
+	  (loadw hi-bits float vm:double-float-value-slot
+		 vm:other-pointer-type))))
+      (signed-stack
+       (sc-case float
+	 (double-reg
+	  (inst stfd float (current-nfp-tn vop)
+		(* (tn-offset hi-bits) vm:word-bytes))))))))
+
+(define-vop (double-float-low-bits)
+  (:args (float :scs (double-reg descriptor-reg)
+		:load-if (not (sc-is float double-stack))))
+  (:results (lo-bits :scs (unsigned-reg)
+		     :load-if (or (sc-is float descriptor-reg double-stack)
+				  (not (sc-is lo-bits unsigned-stack)))))
+  (:temporary (:scs (unsigned-stack)) stack-temp)
+  (:arg-types double-float)
+  (:result-types unsigned-num)
+  (:translate double-float-low-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case lo-bits
+      (unsigned-reg
+       (sc-case float
+	 (double-reg
+	  (inst stfd float (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes))
+	  (inst lwz lo-bits (current-nfp-tn vop)
+		(* (1+ (tn-offset stack-temp)) vm:word-bytes)))
+	 (double-stack
+	  (inst lwz lo-bits (current-nfp-tn vop)
+		(* (1+ (tn-offset float)) vm:word-bytes)))
+	 (descriptor-reg
+	  (loadw lo-bits float (1+ vm:double-float-value-slot)
+		 vm:other-pointer-type))))
+      (unsigned-stack
+       (sc-case float
+	 (double-reg
+	  (inst stfd float (current-nfp-tn vop)
+		(* (tn-offset lo-bits) vm:word-bytes))))))))
+
+
+;;;; 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)))
+  (:result-types unsigned-num)
+  (:translate floating-point-modes)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:temporary (:sc double-stack) temp)
+  (:temporary (:sc single-reg) fp-temp)
+  (:generator 3
+    (let ((nfp (current-nfp-tn vop)))
+      (inst mffs fp-temp)
+      (inst stfd fp-temp nfp (* word-bytes (tn-offset temp)))
+      (loadw res nfp (1+ (tn-offset temp))))))
+
+(define-vop (set-floating-point-modes)
+  (:args (new :scs (unsigned-reg) :target res))
+  (:results (res :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:result-types unsigned-num)
+  (:translate (setf floating-point-modes))
+  (:policy :fast-safe)
+  (:temporary (:sc double-stack) temp)
+  (:temporary (:sc single-reg) fp-temp)
+  (:vop-var vop)
+  (:generator 3
+    (let ((nfp (current-nfp-tn vop)))
+      (storew new nfp (1+ (tn-offset temp)))
+      (inst lfd fp-temp nfp (* word-bytes (tn-offset temp)))
+      (inst mtfsf 255 fp-temp)
+      (move res new))))
diff --git a/compiler/ppc/insts.lisp b/compiler/ppc/insts.lisp
new file mode 100644
index 000000000..a7a97cc61
--- /dev/null
+++ b/compiler/ppc/insts.lisp
@@ -0,0 +1,2059 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/insts.lisp,v 1.1 2001/02/11 14:22:04 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Description of the PPC architecture.
+;;;
+;;; Written by William Lott
+;;;
+
+(in-package "PPC")
+
+(use-package "NEW-ASSEM")
+(use-package "EXT")
+(use-package "C")
+
+(def-assembler-params
+    :scheduler-p nil ; t when we trust the scheduler not to "fill delay slots"
+  :max-locations 70)
+
+
+
+;;;; Constants, types, conversion functions, some disassembler stuff.
+
+(defun reg-tn-encoding (tn)
+  (declare (type tn tn))
+  (sc-case tn
+    (zero zero-offset)
+    (null null-offset)
+    (t
+     (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
+	 (tn-offset tn)
+	 (error "~S isn't a register." tn)))))
+
+(defun fp-reg-tn-encoding (tn)
+  (declare (type tn tn))
+  (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
+    (error "~S isn't a floating-point register." tn))
+  (tn-offset tn))
+
+(disassem:set-disassem-params :instruction-alignment 32)
+
+(defvar *disassem-use-lisp-reg-names* t)
+
+(def-vm-support-routine location-number (loc)
+  (etypecase loc
+    (null)
+    (number)
+    (label)
+    (fixup)
+    (tn
+     (ecase (sb-name (sc-sb (tn-sc loc)))
+       (immediate-constant
+	;; Can happen if $ZERO or $NULL are passed in.
+	nil)
+       (registers
+	(unless (zerop (tn-offset loc))
+	  (tn-offset loc)))
+       (float-registers
+	(+ (tn-offset loc) 32))))
+    (symbol
+     (ecase loc
+       (:memory 0)
+       (:ccr 64)
+       (:xer 65)
+       (:lr 66)
+       (:ctr 67)
+       (:fpscr 68)))))
+
+(defparameter reg-symbols
+  (map 'vector
+       #'(lambda (name)
+	   (cond ((null name) nil)
+		 (t (make-symbol (concatenate 'string "$" name)))))
+       *register-names*))
+
+(disassem:define-argument-type reg
+  :printer #'(lambda (value stream dstate)
+	       (declare (type stream stream) (fixnum value))
+	       (let ((regname (aref reg-symbols value)))
+		 (princ regname stream)
+		 (disassem:maybe-note-associated-storage-ref
+		  value
+		  'registers
+		  regname
+		  dstate))))
+
+(defparameter float-reg-symbols
+  (coerce 
+   (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
+   'vector))
+
+(disassem:define-argument-type fp-reg
+  :printer #'(lambda (value stream dstate)
+	       (declare (type stream stream) (fixnum value))
+	       (let ((regname (aref float-reg-symbols value)))
+		 (princ regname stream)
+		 (disassem:maybe-note-associated-storage-ref
+		  value
+		  'float-registers
+		  regname
+		  dstate))))
+
+(defconstant bo-kind-names #(:bo-dnzf :bo-dnzfp :bo-dzf :bo-dzfp :bo-f :bo-fp nil nil
+                             :bo-dnzt :bo-dnztp :bo-dzt :bo-dztp :bo-t :bo-tp nil nil
+                             :bo-dnz :bo-dnzp :bo-dz :bo-dzp :bo-u nil nil nil
+                             nil nil nil nil nil nil nil nil))
+
+(disassem:define-argument-type bo-field
+  :printer #'(lambda (value stream dstate)
+               (declare (ignore dstate)
+                        (type stream stream)
+                        (type fixnum value))
+               (princ (svref bo-kind-names value) stream)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun valid-bo-encoding (enc)
+  (or (if (integerp enc)
+        (and (= enc (logand #x1f enc))
+             (not (null (svref bo-kind-names enc)))
+             enc)
+        (and enc (position enc bo-kind-names)))
+      (error "Invalid BO field spec: ~s" enc)))
+)
+
+
+(defconstant cr-bit-names #(:lt :gt :eq :so))
+(defconstant cr-bit-inverse-names #(:ge :le :ne :ns))
+
+(defconstant cr-field-names #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7))
+
+(defun valid-cr-bit-encoding (enc &optional error-p)
+  (or (if (integerp enc)
+        (and (= enc (logand 3 enc))
+             enc))
+      (position enc cr-bit-names)
+      (if error-p (error "Invalid condition bit specifier : ~s" enc))))
+
+(defun valid-cr-field-encoding (enc)
+  (let* ((field (if (integerp enc) 
+                  (and (= enc (logand #x7 enc)))
+                  (position enc cr-field-names))))
+    (if field
+      (ash field 2)
+      (error "Invalid condition register field specifier : ~s" enc))))
+                
+(defun valid-bi-encoding (enc)
+  (or
+   (if (atom enc) 
+     (if (integerp enc) 
+       (and (= enc (logand 31 enc)) enc)
+       (position enc cr-bit-names))
+     (+ (valid-cr-field-encoding (car enc))
+        (valid-cr-bit-encoding (cadr enc))))
+   (error "Invalid BI field spec : ~s" enc)))
+
+(disassem:define-argument-type bi-field
+  :printer #'(lambda (value stream dstate)
+               (declare (ignore dstate)
+                        (type stream stream)
+                        (type (unsigned-byte 5) value))
+               (let* ((bitname (svref cr-bit-names (logand 3 value)))
+                      (crfield (ash value -2)))
+                 (declare (type (unsigned-byte 3) crfield))
+                 (if (= crfield 0)
+                   (princ bitname stream)
+                   (princ (list (svref cr-field-names crfield) bitname) stream)))))
+
+(disassem:define-argument-type crf
+  :printer #'(lambda (value stream dstate)
+               (declare (ignore dstate)
+                        (type stream stream)
+                        (type (unsigned-byte 3) value))
+               (princ (svref cr-field-names value) stream)))
+
+(disassem:define-argument-type relative-label
+  :sign-extend t
+  :use-label #'(lambda (value dstate)
+		 (declare (type (signed-byte 14) value)
+			  (type disassem:disassem-state dstate))
+		 (+ (ash value 2) (disassem:dstate-cur-addr dstate))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defconstant trap-values-alist '((:t . 31) (:lt . 16) (:le . 20) (:eq . 4) (:lng . 6)
+                                   (:ge .12) (:ne . 24) (:ng . 20) (:llt . 2) (:f . 0)
+                                   (:lle . 6) (:lge . 5) (:lgt . 1) (:lnl . 5))))
+                                   
+    
+(defun valid-tcond-encoding (enc)
+  (or (and (if (integerp enc) (= (logand 31 enc) enc)) enc)
+      (cdr (assoc enc trap-values-alist))
+      (error "Unknown trap condition: ~s" enc)))
+        
+(disassem:define-argument-type to-field
+  :sign-extend nil
+  :printer #'(lambda (value stream dstate)
+               (declare (ignore dstate)
+                        (type stream stream)
+                        (type fixnum value))
+               (princ (or (car (rassoc value trap-values-alist))
+                          value) 
+                      stream)))
+
+(defun snarf-error-junk (sap offset &optional length-only)
+  (let* ((length (system:sap-ref-8 sap offset))
+         (vector (make-array length :element-type '(unsigned-byte 8))))
+    (declare (type system:system-area-pointer sap)
+             (type (unsigned-byte 8) length)
+             (type (simple-array (unsigned-byte 8) (*)) vector))
+    (cond (length-only
+           (values 0 (1+ length) nil nil))
+          (t
+           (kernel:copy-from-system-area sap (* ppc:byte-bits (1+ offset))
+                                         vector (* ppc:word-bits
+                                                   ppc:vector-data-offset)
+                                         (* length ppc:byte-bits))
+           (collect ((sc-offsets)
+                     (lengths))
+             (lengths 1)                ; the length byte
+             (let* ((index 0)
+                    (error-number (c::read-var-integer vector index)))
+               (lengths index)
+               (loop
+                 (when (>= index length)
+                   (return))
+                 (let ((old-index index))
+                   (sc-offsets (c::read-var-integer vector index))
+                   (lengths (- index old-index))))
+               (values error-number
+                       (1+ length)
+                       (sc-offsets)
+                       (lengths))))))))
+
+
+
+(defun emit-conditional-branch (segment bo bi target &optional aa-p lk-p)
+  (declare (type boolean aa-p lk-p))
+  (let* ((bo (valid-bo-encoding bo))
+         (bi (valid-bi-encoding bi))
+         (aa-bit (if aa-p 1 0))
+         (lk-bit (if lk-p 1 0)))
+    (if aa-p                            ; Not bloody likely, bwth.
+      (emit-b-form-inst segment 16 bo bi target aa-bit lk-bit)
+      (emit-back-patch segment 4
+		       #'(lambda (segment posn)
+		           (emit-b-form-inst 
+                            segment
+                            16
+                            bo
+                            bi
+                            (ash (- (label-position target) posn) -2)
+                            aa-bit
+                            lk-bit))))))
+
+; non-absolute I-form: B, BL.
+(defun emit-i-form-branch (segment target &optional lk-p)
+  (let* ((lk-bit (if lk-p 1 0)))
+    (etypecase target
+      (fixup
+       (note-fixup segment :b target)
+       (emit-i-form-inst segment 18 0 0 lk-bit))
+      (label
+       (emit-back-patch segment 4
+		        #'(lambda (segment posn)
+		            (emit-i-form-inst 
+                             segment
+                             18
+                             (ash (- (label-position target) posn) -2)
+                             0
+                             lk-bit)))))))
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+(defparameter *spr-numbers-alist* '((:xer 1) (:lr 8) (:ctr 9))))
+
+(disassem:define-argument-type spr
+  :printer #'(lambda (value stream dstate)
+               (declare (ignore dstate)
+                        (type (unsigned-byte 10) value))
+               (let* ((name (car (rassoc value *spr-numbers-alist*))))
+                   (if name
+                     (princ name stream)
+                     (princ value stream)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter jump-printer
+    #'(lambda (value stream dstate)
+	(let ((addr (ash value 2)))
+	  (disassem:maybe-note-assembler-routine addr t dstate)
+	  (write addr :base 16 :radix t :stream stream)))))
+
+
+
+;;;; dissassem:define-instruction-formats
+
+(eval-when (:compile-toplevel :execute)
+  (defmacro ppc-byte (startbit &optional (endbit startbit))
+    (unless (and (typep startbit '(unsigned-byte 32))
+                 (typep endbit '(unsigned-byte 32))
+                 (>= endbit startbit))
+      (error "Bad bits."))
+    ``(byte ,(1+ ,(- endbit startbit)) ,(- 31 ,endbit)))
+
+  (defparameter *ppc-field-specs-alist*
+    `((aa :field ,(ppc-byte 30))
+      (ba :field ,(ppc-byte 11 15) :type 'bi-field)
+      (bb :field ,(ppc-byte 16 20) :type 'bi-field)
+      (bd :field ,(ppc-byte 16 29) :type 'relative-label)
+      (bf :field ,(ppc-byte 6 8) :type 'crf)
+      (bfa :field ,(ppc-byte 11 13) :type 'crf)
+      (bi :field ,(ppc-byte 11 15) :type 'bi-field)
+      (bo :field ,(ppc-byte 6 10) :type 'bo-field)
+      (bt :field ,(ppc-byte 6 10) :type 'bi-field)
+      (d :field ,(ppc-byte 16 31) :sign-extend t)
+      (flm :field ,(ppc-byte 7 14) :sign-extend nil)
+      (fra :field ,(ppc-byte 11 15) :type 'fp-reg)
+      (frb :field ,(ppc-byte 16 20) :type 'fp-reg)
+      (frc :field ,(ppc-byte 21 25) :type 'fp-reg)
+      (frs :field ,(ppc-byte 6 10) :type 'fp-reg)
+      (frt :field ,(ppc-byte 6 10) :type 'fp-reg)
+      (fxm :field ,(ppc-byte 12 19) :sign-extend nil)
+      (l :field ,(ppc-byte 10) :sign-extend nil)
+      (li :field ,(ppc-byte 6 29) :sign-extend t :type 'relative-label)
+      (li-abs :field ,(ppc-byte 6 29) :sign-extend t :printer jump-printer)
+      (lk :field ,(ppc-byte 31))
+      (mb :field ,(ppc-byte 21 25) :sign-extend nil)
+      (me :field ,(ppc-byte 26 30) :sign-extend nil)
+      (nb :field ,(ppc-byte 16 20) :sign-extend nil)
+      (oe :field ,(ppc-byte 21))
+      (ra :field ,(ppc-byte 11 15) :type 'reg)
+      (rb :field ,(ppc-byte 16 20) :type 'reg)
+      (rc :field ,(ppc-byte 31))
+      (rs :field ,(ppc-byte 6 10) :type 'reg)
+      (rt :field ,(ppc-byte 6 10) :type 'reg)
+      (sh :field ,(ppc-byte 16 20) :sign-extend nil)
+      (si :field ,(ppc-byte 16 31) :sign-extend t)
+      (spr :field ,(ppc-byte 11 20) :type 'spr)
+      (to :field ,(ppc-byte 6 10) :type 'to-field)
+      (u :field ,(ppc-byte 16 19) :sign-extend nil)
+      (ui :field ,(ppc-byte 16 31) :sign-extend nil)
+      (xo21-30 :field ,(ppc-byte 21 30) :sign-extend nil)
+      (xo22-30 :field ,(ppc-byte 22 30) :sign-extend nil)
+      (xo26-30 :field ,(ppc-byte 26 30) :sign-extend nil)))
+
+(defmacro def-ppc-iformat ((name &optional default-printer) &rest specs)
+  (flet ((specname-field (specname) 
+           (or (assoc specname *ppc-field-specs-alist*)
+               (error "Unknown ppc instruction field spec ~s" specname))))
+    (labels ((spec-field (spec)
+               (if (atom spec)
+                 (specname-field spec)
+                 (cons (car spec)
+                       (cdr (specname-field (cadr spec)))))))
+      (collect ((field (list '(op :field (byte 6 26)))))
+        (dolist (spec specs) 
+          (field (spec-field spec)))
+        `(disassem:define-instruction-format (,name 32 ,@(if default-printer `(:default-printer ,default-printer)))
+           ,@(field))))))
+)
+            
+
+(disassem:define-instruction-format (instr 32)
+  (op :field (byte 6 26))
+  (other :field (byte 26 0)))
+
+(disassem:define-instruction-format (xinstr 32 :default-printer '(:name :tab data))
+  (op-to-a :field (byte 16 16))
+  (data :field (byte 16 0)))
+
+(disassem:define-instruction-format (sc 32 :default-printer '(:name :tab rest))
+  (op :field (byte 6 26))
+  (rest :field (byte 26 0) :value 2))
+
+(def-ppc-iformat (i '(:name :tab li)) 
+  li aa lk)
+
+(def-ppc-iformat (i-abs '(:name :tab li-abs)) 
+  li-abs aa lk)
+
+(def-ppc-iformat (b '(:name :tab bo "," bi "," bd)) 
+  bo bi bd aa lk)
+
+(def-ppc-iformat (d '(:name :tab rt "," d "(" ra ")"))
+  rt ra d)
+
+(def-ppc-iformat (d-si '(:name :tab rt "," ra "," si ))
+  rt ra si)
+
+(def-ppc-iformat (d-rs '(:name :tab rs "," d "(" ra ")"))
+  rs ra d)
+
+(def-ppc-iformat (d-rs-ui '(:name :tab ra "," rs "," ui))
+  rs ra ui)
+
+(def-ppc-iformat (d-crf-si)
+  bf l ra si)
+
+(def-ppc-iformat (d-crf-ui)
+  bf l ra ui)
+
+(def-ppc-iformat (d-to '(:name :tab to "," ra "," si))
+  to ra rb si)
+
+(def-ppc-iformat (d-frt '(:name :tab frt "," d "(" ra ")"))
+  frt ra d)
+
+(def-ppc-iformat (d-frs '(:name :tab frs "," d "(" ra ")"))
+  frs ra d)
+
+
+
+;;; There are around ... oh, 28 or so ... variants on the "X" format.
+;;;  Some of them are only used by one instruction; some are used by dozens.
+;;;  Some aren't used by instructions that we generate ...
+
+(def-ppc-iformat (x '(:name :tab rt "," ra "," rb))
+  rt ra rb (xo xo21-30))
+
+(def-ppc-iformat (x-1 '(:name :tab rt "," ra "," nb))
+  rt ra nb (xo xo21-30))
+
+(def-ppc-iformat (x-4 '(:name :tab rt))
+  rt (xo xo21-30))
+
+(def-ppc-iformat (x-5 '(:name :tab ra "," rs "," rb))
+  rs ra rb (xo xo21-30) rc)
+
+(def-ppc-iformat (x-7 '(:name :tab ra "," rs "," rb))
+  rs ra rb (xo xo21-30))
+
+(def-ppc-iformat (x-8 '(:name :tab ra "," rs "," nb))
+  rs ra nb (xo xo21-30))
+
+(def-ppc-iformat (x-9 '(:name :tab ra "," rs "," sh))
+  rs ra sh (xo xo21-30) rc)
+
+(def-ppc-iformat (x-10 '(:name :tab ra "," rs))
+  rs ra (xo xo21-30) rc)
+
+(def-ppc-iformat (x-14 '(:name :tab bf "," l "," ra "," rb))
+  bf l ra rb (xo xo21-30))
+
+(def-ppc-iformat (x-15 '(:name :tab bf "," l "," fra "," frb))
+  bf l fra frb (xo xo21-30))
+
+(def-ppc-iformat (x-18 '(:name :tab bf))
+  bf (xo xo21-30))
+
+(def-ppc-iformat (x-19 '(:name :tab to "," ra "," rb))
+  to ra rb (xo xo21-30))
+
+(def-ppc-iformat (x-20 '(:name :tab frt "," ra "," rb))
+  frt ra rb (xo xo21-30))
+
+(def-ppc-iformat (x-21 '(:name :tab frt "," rb))
+  frt rb (xo xo21-30) rc)
+
+(def-ppc-iformat (x-22 '(:name :tab frt))
+  frt (xo xo21-30) rc)
+
+(def-ppc-iformat (x-23 '(:name :tab ra "," frs "," rb))
+  frs ra rb (xo xo21-30))
+
+(def-ppc-iformat (x-24 '(:name :tab bt))
+  bt (xo xo21-30) rc)
+
+(def-ppc-iformat (x-25 '(:name :tab ra "," rb))
+  ra rb (xo xo21-30))
+
+(def-ppc-iformat (x-26 '(:name :tab rb))
+  rb (xo xo21-30))
+
+(def-ppc-iformat (x-27 '(:name))
+  (xo xo21-30))
+
+
+;;;;
+
+(def-ppc-iformat (xl '(:name :tab bt "," ba "," bb))
+  bt ba bb (xo xo21-30))
+
+(def-ppc-iformat (xl-bo-bi '(:name :tab bo "," bi))
+  bo bi (xo xo21-30) lk)
+
+(def-ppc-iformat (xl-cr '(:name :tab bf "," bfa))
+  bf bfa (xo xo21-30))
+
+(def-ppc-iformat (xl-xo '(:name))
+  (xo xo21-30))
+
+
+;;;;
+
+(def-ppc-iformat (xfx 32)
+  rt spr (xo xo21-30))
+
+(def-ppc-iformat (xfx-fxm '(:name :tab fxm "," rs))
+  rs fxm (xo xo21-30))
+
+(def-ppc-iformat (xfl '(:name :tab flm "," frb))
+  flm frb (xo xo21-30) rc)
+
+
+;;;
+
+(def-ppc-iformat (xo '(:name :tab rt "," ra "," rb))
+  rt ra rb oe (xo xo22-30) rc)
+
+(def-ppc-iformat (xo-oe '(:name :tab rt "," ra "," rb))
+  rt ra rb (xo xo22-30) rc)
+
+(def-ppc-iformat (xo-a '(:name :tab rt "," ra))
+  rt ra oe (xo xo22-30) rc)
+
+
+;;;
+
+(def-ppc-iformat (a '(:name :tab frt "," fra "," frb "," frc))
+  frt fra frb frc (xo xo26-30) rc)
+
+(def-ppc-iformat (a-tab '(:name :tab frt "," fra "," frb))
+  frt fra frb (xo xo26-30) rc)
+
+(def-ppc-iformat (a-tac '(:name :tab frt "," fra "," frc))
+  frt fra frc (xo xo26-30) rc)
+
+(def-ppc-iformat (a-tbc '(:name :tab frt "," frb "," frc))
+  frt frb frc (xo xo26-30) rc)
+
+
+(def-ppc-iformat (m '(:name :tab ra "," rs "," rb "," mb "," me))
+  rs ra rb mb me rc)
+
+(def-ppc-iformat (m-sh '(:name :tab ra "," rs "," sh "," mb "," me))
+  rs ra sh mb me rc)
+
+
+
+
+;;;; Primitive emitters.
+
+
+(define-emitter emit-word 32
+  (byte 32 0))
+
+(define-emitter emit-short 16
+  (byte 16 0))
+
+(define-emitter emit-i-form-inst 32
+  (byte 6 26) (byte 24 2) (byte 1 1) (byte 1 0))
+
+(define-emitter emit-b-form-inst 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 14 2) (byte 1 1) (byte 1 0))
+
+(define-emitter emit-sc-form-inst 32
+  (byte 6 26) (byte 26 0))
+
+(define-emitter emit-d-form-inst 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
+
+; Also used for XL-form.  What's the difference ?
+(define-emitter emit-x-form-inst 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 10 1) (byte 1 0))
+
+(define-emitter emit-xfx-form-inst 32
+  (byte 6 26) (byte 5 21) (byte 10 11) (byte 10 1) (byte 1 0))
+
+(define-emitter emit-xfl-form-inst 32
+  (byte 6 26) (byte 10  16) (byte 5 11) (byte 10 1) (byte 1 0))
+
+; XS is 64-bit only
+(define-emitter emit-xo-form-inst 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 1 10) (byte 9 1) (byte 1 0))
+
+(define-emitter emit-a-form-inst 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 5 1) (byte 1 0))
+
+
+
+
+(defun unimp-control (chunk inst stream dstate)
+  (declare (ignore inst))
+  (flet ((nt (x) (if stream (disassem:note x dstate))))
+    (case (xinstr-data chunk dstate)
+      (#.vm:error-trap
+       (nt "Error trap")
+       (disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.vm:cerror-trap
+       (nt "Cerror trap")
+       (disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.vm:object-not-list-trap
+       (nt "Object not list trap"))
+      (#.vm:breakpoint-trap
+       (nt "Breakpoint trap"))
+      (#.vm:pending-interrupt-trap
+       (nt "Pending interrupt trap"))
+      (#.vm:halt-trap
+       (nt "Halt trap"))
+      (#.vm:function-end-breakpoint-trap
+       (nt "Function end breakpoint trap"))
+      (#.vm:object-not-instance-trap
+       (nt "Object not instance trap"))
+    )))
+
+(eval-when (:compile-toplevel :execute)
+
+(defun classify-dependencies (deplist)
+  (collect ((reads) (writes))
+    (dolist (dep deplist)
+      (ecase (car dep)
+        (reads (reads dep))
+        (writes (writes dep))))
+    (values (reads) (writes))))
+
+(defmacro define-xo-instruction (name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
+  `(define-instruction ,name (segment rt ra rb)
+     (:printer xo ((op ,op ) (xo ,xo) (oe ,(if oe-p 1 0)) (rc ,(if rc-p 1 0))))
+     (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer))) 
+                    (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if (or oe-p always-writes-xer) '((writes :xer))) )
+     (:cost ,cost)
+     (:delay ,cost)
+     (:emitter
+      (emit-xo-form-inst segment ,op
+                         (reg-tn-encoding rt) 
+                         (reg-tn-encoding ra) 
+                         (reg-tn-encoding rb)
+                         ,(if oe-p 1 0)
+                         ,xo
+                         ,(if rc-p 1 0)))))
+
+(defmacro define-xo-oe-instruction (name op xo rc-p always-reads-xer always-writes-xer cost)
+  `(define-instruction ,name (segment rt ra rb)
+     (:printer xo-oe ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
+     (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer))) 
+                    (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if always-writes-xer '((writes :xer))))
+     (:cost ,cost)
+     (:delay ,cost)
+     (:emitter
+      (emit-xo-form-inst segment ,op
+                         (reg-tn-encoding rt) 
+                         (reg-tn-encoding ra) 
+                         (reg-tn-encoding rb)
+                         0
+                         ,xo
+                         (if ,rc-p 1 0)))))
+
+(defmacro define-4-xo-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1))
+  `(progn
+    (define-xo-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost)
+    (define-xo-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost)
+    (define-xo-instruction ,(symbolicate base "O") ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost)
+    (define-xo-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost)))
+
+(defmacro define-2-xo-oe-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1))
+  `(progn
+    (define-xo-oe-instruction ,base ,op ,xo nil ,always-reads-xer ,always-writes-xer ,cost)
+    (define-xo-oe-instruction ,(symbolicate base ".") ,op ,xo t ,always-reads-xer ,always-writes-xer ,cost)))
+
+(defmacro define-xo-a-instruction (name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
+  `(define-instruction ,name (segment rt ra)
+     (:printer xo-a ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)) (oe ,(if oe-p 1 0))))
+     (:dependencies (reads ra) ,@(if always-reads-xer '((reads :xer)))
+                    (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if always-writes-xer '((writes :xer))) )
+     (:cost ,cost)
+     (:delay ,cost)
+     (:emitter
+      (emit-xo-form-inst segment ,op
+                         (reg-tn-encoding rt) 
+                         (reg-tn-encoding ra) 
+                         0
+                         (if ,oe-p 1 0)
+                         ,xo
+                         (if ,rc-p 1 0)))))
+
+(defmacro define-4-xo-a-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1))
+  `(progn
+    (define-xo-a-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost)
+    (define-xo-a-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost)
+    (define-xo-a-instruction ,(symbolicate base "O")  ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost)
+    (define-xo-a-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost)))
+
+(defmacro define-x-instruction (name op xo &key (cost 2) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment rt ra rb)
+       (:printer x ((op ,op) (xo ,xo)))
+       (:delay ,cost)
+       (:cost ,cost)
+       (:dependencies (reads ra) (reads rb) ,@ other-reads 
+                      (writes rt) ,@other-writes)
+       (:emitter
+        (emit-x-form-inst segment ,op 
+                          (reg-tn-encoding rt) 
+                          (reg-tn-encoding ra)
+                          (reg-tn-encoding rb)
+                          ,xo
+                          0)))))
+
+(defmacro define-x-20-instruction (name op xo &key (cost 2) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment frt ra rb)
+       (:printer x-20 ((op ,op) (xo ,xo)))
+       (:delay ,cost)
+       (:cost ,cost)
+       (:dependencies (reads ra) (reads rb) ,@other-reads 
+                      (writes frt) ,@other-writes)
+       (:emitter
+        (emit-x-form-inst segment ,op 
+                          (fp-reg-tn-encoding frt) 
+                          (reg-tn-encoding ra)
+                          (reg-tn-encoding rb)
+                          ,xo
+                          0)))))
+
+(defmacro define-x-5-instruction (name op xo rc-p &key (cost 1) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment ra rs rb)
+       (:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
+       (:delay ,cost)
+       (:cost ,cost)
+       (:dependencies (reads rb) (reads rs) ,@other-reads 
+                      (writes ra) ,@other-writes)
+       (:emitter
+        (emit-x-form-inst segment ,op 
+                          (reg-tn-encoding rs) 
+                          (reg-tn-encoding ra)
+                          (reg-tn-encoding rb)
+                          ,xo
+                          ,(if rc-p 1 0))))))
+
+
+(defmacro define-x-5-st-instruction (name op xo rc-p &key (cost 1) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment rs ra rb)
+       (:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
+       (:delay ,cost)
+       (:cost ,cost)
+       (:dependencies (reads ra) (reads rb) (reads rs) ,@other-reads 
+                      ,@other-writes)
+       (:emitter
+        (emit-x-form-inst segment ,op 
+                          (reg-tn-encoding rs) 
+                          (reg-tn-encoding ra)
+                          (reg-tn-encoding rb)
+                          ,xo
+                          ,(if rc-p 1 0))))))
+
+(defmacro define-x-23-st-instruction (name op xo &key (cost 1) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment frs ra rb)
+       (:printer x-23 ((op ,op) (xo ,xo)))
+       (:delay ,cost)
+       (:cost ,cost)
+       (:dependencies (reads ra) (reads rb) (reads frs) ,@other-reads 
+                      ,@other-writes)
+       (:emitter
+        (emit-x-form-inst segment ,op 
+                          (fp-reg-tn-encoding frs) 
+                          (reg-tn-encoding ra)
+                          (reg-tn-encoding rb)
+                          ,xo
+                          0)))))
+
+
+(defmacro define-x-10-instruction (name op xo rc-p &key (cost 1) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment ra rs)
+       (:printer x-10 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
+       (:delay ,cost)
+       (:cost ,cost)
+       (:dependencies (reads rs) ,@other-reads 
+                      (writes ra) ,@other-writes)
+       (:emitter
+        (emit-x-form-inst segment ,op 
+                          (reg-tn-encoding rs) 
+                          (reg-tn-encoding ra)
+                          0
+                          ,xo
+                          ,(if rc-p 1 0))))))
+
+(defmacro define-2-x-5-instructions (name op xo &key (cost 1) other-dependencies)
+  `(progn
+     (define-x-5-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
+     (define-x-5-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost 
+       :other-dependencies ,other-dependencies)))
+
+(defmacro define-2-x-10-instructions (name op xo &key (cost 1) other-dependencies)
+  `(progn
+     (define-x-10-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
+     (define-x-10-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost 
+       :other-dependencies ,other-dependencies)))
+
+
+(defmacro define-x-21-instruction (name op xo rc-p &key (cost 4) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment frt frb)
+       (:printer x-21 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
+       (:cost ,cost)
+       (:delay ,cost)
+       (:dependencies (reads frb) ,@other-reads 
+                      (writes frt) ,@other-writes)
+       (:emitter
+        (emit-x-form-inst segment ,op
+                          (fp-reg-tn-encoding frt)
+                          0
+                          (fp-reg-tn-encoding frb)
+                          ,xo
+                          ,(if rc-p 1 0))))))
+
+(defmacro define-2-x-21-instructions (name op xo &key (cost 4) other-dependencies)
+  `(progn
+     (define-x-21-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
+     (define-x-21-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost 
+       :other-dependencies ,other-dependencies)))
+
+
+(defmacro define-d-si-instruction (name op &key (fixup nil) (cost 1) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+  `(define-instruction ,name (segment rt ra si)
+     (:declare (type (signed-byte 16)))
+     (:printer d-si ((op ,op)))
+     (:delay ,cost)
+     (:cost ,cost)
+     (:dependencies (reads ra) ,@other-reads 
+                    (writes rt) ,@other-writes)
+     (:emitter
+      (when (typep si 'fixup)
+	(ecase ,fixup
+	  ((:ha :l) (note-fixup segment ,fixup si)))
+	(setq si 0))      
+      (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si)))))
+
+
+(defmacro define-d-rs-ui-instruction (name op &key (cost 1) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment ra rs ui)
+       (:declare (type (unsigned-byte 16) ui))
+       (:printer d-rs-ui ((op ,op)))
+       (:cost ,cost)
+       (:delay ,cost)
+       (:dependencies (reads rs) ,@other-reads 
+                      (writes ra) ,@other-writes)
+       (:emitter
+        (emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) ui)))))
+
+(defmacro define-d-instruction (name op &key (cost 2) other-dependencies pinned)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment rt ra si)
+       (:declare (type (signed-byte 16) si))
+       (:printer d ((op ,op)))
+       (:delay ,cost)
+       (:cost ,cost)
+       ,@(when pinned '(:pinned))
+       (:dependencies (reads ra) ,@other-reads 
+                      (writes rt) ,@other-writes)
+       (:emitter
+        (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si)))))
+
+(defmacro define-d-frt-instruction (name op &key (cost 3) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+  `(define-instruction ,name (segment frt ra si)
+     (:declare (type (signed-byte 16) si))
+     (:printer d-frt ((op ,op)))
+     (:delay ,cost)
+     (:cost ,cost)
+     (:dependencies (reads ra) ,@other-reads 
+                    (writes frt) ,@other-writes)
+     (:emitter
+      (emit-d-form-inst segment ,op (fp-reg-tn-encoding frt) (reg-tn-encoding ra) si)))))
+
+(defmacro define-d-rs-instruction (name op &key (cost 1) other-dependencies pinned)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment rs ra si)
+       (:declare (type (signed-byte 16) si))
+       (:printer d-rs ((op ,op)))
+       (:delay ,cost)
+       (:cost ,cost)
+       ,@(when pinned '(:pinned))
+       (:dependencies (reads rs) (reads ra) ,@other-reads 
+                      (writes :memory :partially t) ,@other-writes)
+       (:emitter
+        (emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) si)))))
+
+(defmacro define-d-frs-instruction (name op &key (cost 1) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+  `(define-instruction ,name (segment frs ra si)
+     (:declare (type (signed-byte 16) si))
+     (:printer d-frs ((op ,op)))
+     (:delay ,cost)
+     (:cost ,cost)
+     (:dependencies (reads frs) (reads ra) ,@other-reads 
+                    (writes :memory :partially t) ,@other-writes)
+     (:emitter
+      (emit-d-form-inst segment ,op (fp-reg-tn-encoding frs) (reg-tn-encoding ra) si)))))
+
+(defmacro define-a-instruction (name op xo rc &key (cost 1) other-dependencies)
+  `(define-instruction ,name (segment frt fra frb frc)
+     (:printer a ((op ,op) (xo ,xo) (rc ,rc)))
+     (:cost ,cost)
+     (:delay ,cost)
+     (:dependencies (writes frt) (reads fra) (reads frb) (reads frc) ,@other-dependencies)
+     (:emitter
+        (emit-a-form-inst segment 
+                          ,op 
+                          (fp-reg-tn-encoding frt) 
+                          (fp-reg-tn-encoding fra) 
+                          (fp-reg-tn-encoding frb)
+                          (fp-reg-tn-encoding frb)
+                          ,xo
+                          ,rc))))
+
+(defmacro define-2-a-instructions (name op xo &key (cost 1) other-dependencies)
+  `(progn
+     (define-a-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
+     (define-a-instruction ,(symbolicate name ".")
+       ,op ,xo 1  :cost ,cost :other-dependencies ,other-dependencies)))
+
+(defmacro define-a-tab-instruction (name op xo rc &key (cost 1) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment frt fra frb)
+       (:printer a-tab ((op ,op) (xo ,xo) (rc ,rc)))
+       (:cost ,cost)
+       (:delay 1)
+       (:dependencies (reads fra) (reads frb) ,@other-reads
+                      (writes frt) ,@other-writes)
+       (:emitter
+        (emit-a-form-inst segment 
+                          ,op 
+                          (fp-reg-tn-encoding frt) 
+                          (fp-reg-tn-encoding fra) 
+                          (fp-reg-tn-encoding frb)
+                          0
+                          ,xo
+                          ,rc)))))
+
+(defmacro define-2-a-tab-instructions (name op xo &key (cost 1) other-dependencies)
+  `(progn
+     (define-a-tab-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
+     (define-a-tab-instruction ,(symbolicate name ".")
+       ,op ,xo 1  :cost ,cost :other-dependencies ,other-dependencies)))
+
+(defmacro define-a-tac-instruction (name op xo rc &key (cost 1) other-dependencies)
+  (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
+    `(define-instruction ,name (segment frt fra frc)
+       (:printer a-tac ((op ,op) (xo ,xo) (rc ,rc)))
+       (:cost ,cost)
+       (:delay 1)
+       (:dependencies (reads fra) (reads frb) ,@other-reads
+                      (writes frt) ,@other-writes)
+       (:emitter
+        (emit-a-form-inst segment 
+                          ,op 
+                          (fp-reg-tn-encoding frt) 
+                          (fp-reg-tn-encoding fra) 
+                          0
+                          (fp-reg-tn-encoding frc)
+                          ,xo
+                          ,rc)))))
+
+(defmacro define-2-a-tac-instructions (name op xo &key (cost 1) other-dependencies)
+  `(progn
+     (define-a-tac-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
+     (define-a-tac-instruction ,(symbolicate name ".")
+       ,op ,xo 1  :cost ,cost :other-dependencies ,other-dependencies)))
+
+(defmacro define-crbit-instruction (name op xo)
+  `(define-instruction ,name (segment dbit abit bbit)
+     (:printer xl ((op ,op ) (xo ,xo)))
+     (:delay 1)
+     (:cost 1)
+     (:dependencies (reads :ccr) (writes :ccr))
+     (:emitter (emit-x-form-inst segment 19
+                                 (valid-bi-encoding dbit)
+                                 (valid-bi-encoding abit)
+                                 (valid-bi-encoding bbit)
+                                 ,xo
+                                 0))))
+);eval-when
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; The instructions, in numerical order
+
+(define-instruction unimp (segment data)
+  (:declare (type (signed-byte 16) data))
+  (:printer xinstr ((op-to-a #.(logior (ash 3 10) (ash 6 5) 0)))
+	    :default :control #'unimp-control)
+  :pinned
+  (:delay 0)
+  (:emitter (emit-d-form-inst segment 3 6 0 data)))
+
+(define-instruction twi (segment tcond ra si)
+  (:printer d-to ((op 3)))
+  (:delay 1)
+  :pinned
+  (:emitter (emit-d-form-inst segment 3 (valid-tcond-encoding tcond) (reg-tn-encoding ra) si)))
+
+(define-d-si-instruction mulli 7 :cost 5)
+(define-d-si-instruction subfic 8)
+
+(define-instruction cmplwi (segment crf ra &optional (ui nil ui-p))
+  (:printer d-crf-ui ((op 10) (l 0)) '(:name :tab bf "," ra "," ui))
+  (:dependencies (if ui-p (reads ra) (reads crf)) (writes :ccr))
+  (:delay 1)
+  (:emitter 
+   (unless ui-p
+     (setq ui ra ra crf crf :cr0))
+   (emit-d-form-inst segment 
+                     10
+                     (valid-cr-field-encoding crf) 
+                     (reg-tn-encoding ra)
+                     ui)))
+
+(define-instruction cmpwi (segment crf ra  &optional (si nil si-p))
+  (:printer d-crf-si ((op 11) (l 0)) '(:name :tab bf "," ra "," si))
+  (:dependencies (if si-p (reads ra) (reads crf)) (writes :ccr))
+  (:delay 1)
+  (:emitter 
+   (unless si-p
+     (setq si ra ra crf crf :cr0))
+   (emit-d-form-inst segment 
+                     11
+                     (valid-cr-field-encoding crf) 
+                     (reg-tn-encoding ra)
+                     si)))
+
+(define-d-si-instruction addic 12 :other-dependencies ((writes :xer)))
+(define-d-si-instruction addic. 13 :other-dependencies ((writes :xer) (writes :ccr)))
+
+(define-d-si-instruction addi 14 :fixup :l)
+(define-d-si-instruction addis 15 :fixup :ha)
+
+; There's no real support here for branch options that decrement and test the CTR.
+;  (a) the instruction scheduler doesn't know that anything's happening to the CTR
+;  (b) Lisp may have to assume that the CTR always has a lisp object/locative in it.
+
+(define-instruction bc (segment bo bi target)
+  (:declare (type label target))
+  (:printer b ((op 16) (aa 0) (lk 0)))
+  (:delay 1)
+  (:dependencies (reads :ccr))
+  (:emitter
+   (emit-conditional-branch segment bo bi target)))
+
+(define-instruction bcl (segment bo bi target)
+  (:declare (type label target))
+  (:printer b ((op 16) (aa 0) (lk 1)))
+  (:delay 1)
+  (:dependencies (reads :ccr))
+  (:emitter
+   (emit-conditional-branch segment bo bi target nil t)))
+
+(define-instruction bca (segment bo bi target)
+  (:declare (type label target))
+  (:printer b ((op 16) (aa 1) (lk 0)))
+  (:delay 1)
+  (:dependencies (reads :ccr))
+  (:emitter
+   (emit-conditional-branch segment bo bi target t)))
+
+(define-instruction bcla (segment bo bi target)
+  (:declare (type label target))
+  (:printer b ((op 16) (aa 1) (lk 1)))
+  (:delay 1)
+  (:dependencies (reads :ccr))
+  (:emitter
+   (emit-conditional-branch segment bo bi target t t)))
+
+;;; There may (or may not) be a good reason to use this in preference to "b[la] target".
+;;; I can't think of a -bad- reason ...
+
+(define-instruction bu (segment target)
+  (:declare (type label target))
+  (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (aa 0) (lk 0)) 
+            '(:name :tab bd))
+  (:delay 1)
+  (:emitter
+   (emit-conditional-branch segment #.(valid-bo-encoding :bo-u) 0 target nil nil)))
+
+
+(define-instruction bt (segment bi  target)
+  (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-t)) (aa 0) (lk 0))
+            '(:name :tab bi "," bd))
+  (:delay 1)
+  (:emitter
+   (emit-conditional-branch segment #.(valid-bo-encoding :bo-t) bi target nil nil)))
+
+(define-instruction bf (segment bi  target)
+  (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-f)) (aa 0) (lk 0))
+            '(:name :tab bi "," bd))
+  (:delay 1)
+  (:emitter
+   (emit-conditional-branch segment #.(valid-bo-encoding :bo-f) bi target nil nil)))
+
+(define-instruction b? (segment cr-field-name cr-name  &optional (target nil target-p))
+  (:delay 1)
+  (:emitter 
+   (unless target-p
+     (setq target cr-name cr-name cr-field-name cr-field-name :cr0))
+   (let*  ((+cond (position cr-name cr-bit-names))
+                    (-cond (position cr-name cr-bit-inverse-names))
+                    (b0 (if +cond :bo-t 
+                            (if -cond 
+                              :bo-f
+                              (error "Unknown branch condition ~s" cr-name))))
+                    (cr-form (list cr-field-name (if +cond cr-name (svref cr-bit-names -cond)))))
+              (emit-conditional-branch segment b0 cr-form target))))
+
+(define-instruction sc (segment)
+  (:printer sc ((op 17)))
+  (:delay 1)
+  :pinned
+  (:emitter (emit-sc-form-inst segment 17 2)))
+
+(define-instruction b (segment target)
+  (:printer i ((op 18) (aa 0) (lk 0)))
+  (:delay 1)
+  (:emitter
+   (emit-i-form-branch segment target nil)))
+
+(define-instruction ba (segment target)
+  (:printer i-abs ((op 18) (aa 1) (lk 0)))
+  (:delay 1)
+  (:emitter
+   (when (typep target 'fixup)
+     (note-fixup segment :ba target)
+     (setq target 0))
+   (emit-i-form-inst segment 18 (ash target -2) 1 0)))
+
+
+(define-instruction bl (segment target)
+  (:printer i ((op 18) (aa 0) (lk 1)))
+  (:delay 1)
+  (:emitter
+   (emit-i-form-branch segment target t)))
+
+(define-instruction bla (segment target)
+  (:printer i-abs ((op 18) (aa 1) (lk 1)))
+  (:delay 1)
+  (:emitter
+   (when (typep target 'fixup)
+     (note-fixup segment :ba target)
+     (setq target 0))
+   (emit-i-form-inst segment 18 (ash target -2) 1 1)))
+
+(define-instruction blr (segment)
+  (:printer xl-bo-bi ((op 19) (xo 16) (bo #.(valid-bo-encoding :bo-u))(bi 0) (lk 0))  '(:name))
+  (:delay 1)
+  (:dependencies (reads :ccr) (reads :ctr))
+  (:emitter
+   (emit-x-form-inst segment 19 (valid-bo-encoding :bo-u) 0 0 16 0)))
+
+(define-instruction bclr (segment bo bi)
+  (:printer xl-bo-bi ((op 19) (xo 16)))
+  (:delay 1)
+  (:dependencies (reads :ccr) (reads :lr))
+  (:emitter
+   (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 16 0)))
+
+(define-instruction bclrl (segment bo bi)
+  (:printer xl-bo-bi ((op 19) (xo 16) (lk 1)))
+  (:delay 1)
+  (:dependencies (reads :ccr) (reads :lr))
+  (:emitter
+   (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 16 1)))
+
+(define-crbit-instruction crnor 19 33)
+(define-crbit-instruction crandc 19 129)
+(define-instruction isync (segment)
+  (:printer xl-xo ((op 19) (xo 150)))
+  (:delay 1)
+  :pinned
+  (:emitter (emit-x-form-inst segment 19 0 0 0 150 0)))
+
+(define-crbit-instruction crxor 19 193)
+(define-crbit-instruction crnand 19 225)
+(define-crbit-instruction crand 19 257)
+(define-crbit-instruction creqv 19 289)
+(define-crbit-instruction crorc 19 417)
+(define-crbit-instruction cror 19 449)
+
+(define-instruction bcctr (segment bo bi)
+  (:printer xl-bo-bi ((op 19) (xo 528)))
+  (:delay 1)
+  (:dependencies (reads :ccr) (reads :ctr))
+  (:emitter
+   (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 0)))
+
+(define-instruction bcctrl (segment bo bi)
+  (:printer xl-bo-bi ((op 19) (xo 528) (lk 1)))
+  (:delay 1)
+  (:dependencies (reads :ccr) (reads :ctr) (writes :lr))
+  (:emitter
+   (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 1)))
+
+(define-instruction bctr (segment)
+  (:printer xl-bo-bi ((op 19) (xo 528) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (lk 0))  '(:name))
+  (:delay 1)
+  (:dependencies (reads :ccr) (reads :ctr))
+  (:emitter
+   (emit-x-form-inst segment 19 #.(valid-bo-encoding :bo-u) 0 0  528 0)))
+
+(define-instruction bctrl (segment)
+  (:printer xl-bo-bi ((op 19) (xo 528) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (lk 1))  '(:name))
+  (:delay 1)
+  (:dependencies (reads :ccr) (reads :ctr))
+  (:emitter
+   (emit-x-form-inst segment 19 #.(valid-bo-encoding :bo-u) 0 0  528 1)))
+
+(define-instruction rlwimi (segment ra rs sh mb me)
+  (:printer m-sh ((op 20) (rc 0)))
+  (:dependencies (reads rs) (writes ra))
+  (:delay 1)
+  (:emitter
+   (emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0)))
+
+(define-instruction rlwimi. (segment ra rs sh mb me)
+  (:printer m-sh ((op 20) (rc 1)))
+  (:dependencies (reads rs) (writes ra) (writes :ccr))
+  (:delay 1)
+  (:emitter
+   (emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1)))
+
+(define-instruction rlwinm (segment ra rs sh mb me)
+  (:printer m-sh ((op 21) (rc 0)))
+  (:delay 1)
+  (:dependencies (reads rs) (writes ra))
+  (:emitter
+   (emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0)))
+
+(define-instruction rlwinm. (segment ra rs sh mb me)
+  (:printer m-sh ((op 21) (rc 1)))
+  (:delay 1)
+  (:dependencies (reads rs) (writes ra) (writes :ccr))
+  (:emitter
+   (emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1)))
+
+(define-instruction rlwnm (segment ra rs rb mb me)
+  (:printer m ((op 23) (rc 0) (rb nil :type 'reg)))
+  (:delay 1)
+  (:dependencies (reads rs) (writes ra) (reads rb))
+  (:emitter
+   (emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 0)))
+
+(define-instruction rlwnm. (segment ra rs rb mb me)
+  (:printer m ((op 23) (rc 1) (rb nil :type 'reg)))
+  (:delay 1)
+  (:dependencies (reads rs) (reads rb) (writes ra) (writes :ccr))
+  (:emitter
+   (emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 1)))
+
+
+(define-d-rs-ui-instruction ori 24)
+
+(define-instruction nop (segment)
+  (:printer d-rs-ui ((op 24) (rs 0) (ra 0) (ui 0)) '(:name))
+  (:cost 1)
+  (:delay 1)
+  (:emitter
+   (emit-d-form-inst segment 24 0 0 0)))
+
+(define-d-rs-ui-instruction oris 25)
+(define-d-rs-ui-instruction xori 26)
+(define-d-rs-ui-instruction xoris 27)
+(define-d-rs-ui-instruction andi. 28 :other-dependencies ((writes :ccr)))
+(define-d-rs-ui-instruction andis. 29 :other-dependencies ((writes :ccr)))
+
+(define-instruction cmpw (segment crf ra  &optional (rb nil rb-p))
+  (:printer x-14 ((op 31) (xo 0) (l 0)) '(:name :tab bf "," ra "," rb))
+  (:delay 1)
+  (:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr))
+  (:emitter 
+   (unless rb-p
+     (setq rb ra ra crf crf :cr0))
+   (emit-x-form-inst segment 
+                              31
+                              (valid-cr-field-encoding crf) 
+                              (reg-tn-encoding ra)
+                              (reg-tn-encoding rb)
+                              0
+                              0)))
+
+(define-instruction tw (segment tcond ra rb)
+  (:printer x-19 ((op 31) (xo 4)))
+  (:delay 1)
+  :pinned
+  (:emitter (emit-x-form-inst segment 31 (valid-tcond-encoding tcond) (reg-tn-encoding ra) (reg-tn-encoding rb) 4 0)))
+
+(define-4-xo-instructions subfc 31 8 :always-writes-xer t)
+(define-4-xo-instructions addc 31 10 :always-writes-xer t)
+(define-2-xo-oe-instructions mulhwu 31 11 :cost 5)
+
+(define-instruction mfcr (segment rd)
+  (:printer x-4 ((op 31) (xo 19)))
+  (:delay 1)
+  (:dependencies (reads :ccr) (writes rd))
+  (:emitter (emit-x-form-inst segment 31 (reg-tn-encoding rd) 0 0 19 0)))
+
+(define-x-instruction lwarx 31 20)
+(define-x-instruction lwzx 31 23)
+(define-2-x-5-instructions slw 31 24)
+(define-2-x-10-instructions cntlzw 31 26)
+(define-2-x-5-instructions and 31 28)
+
+(define-instruction cmplw (segment crf ra  &optional (rb nil rb-p))
+  (:printer x-14 ((op 31) (xo 32) (l 0)) '(:name :tab bf "," ra "," rb))
+  (:delay 1)
+  (:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr))
+  (:emitter 
+   (unless rb-p
+     (setq rb ra ra crf crf :cr0))
+   (emit-x-form-inst segment 
+                     31
+                     (valid-cr-field-encoding crf) 
+                     (reg-tn-encoding ra)
+                     (reg-tn-encoding rb)
+                     32
+                     0)))
+
+
+(define-4-xo-instructions subf 31 40)
+; dcbst
+(define-x-instruction lwzux 31 55 :other-dependencies ((writes rt)))
+(define-2-x-5-instructions andc 31 60)
+(define-2-xo-oe-instructions mulhw 31 75 :cost 5)
+
+(define-x-instruction lbzx 31 87)
+(define-4-xo-a-instructions neg 31 104)
+(define-x-instruction lbzux 31 119 :other-dependencies ((writes rt)))
+(define-2-x-5-instructions nor 31 124)
+(define-4-xo-instructions subfe 31 136 :always-reads-xer t :always-writes-xer t)
+
+(define-instruction-macro sube (rt ra rb)
+  `(inst subfe ,rt ,rb ,ra))
+
+(define-instruction-macro sube. (rt ra rb)
+  `(inst subfe. ,rt ,rb ,ra))
+
+(define-instruction-macro subeo (rt ra rb)
+  `(inst subfeo ,rt ,rb ,ra))
+
+(define-instruction-macro subeo. (rt ra rb)
+  `(inst subfeo ,rt ,rb ,ra))
+
+(define-4-xo-instructions adde 31 138 :always-reads-xer t :always-writes-xer t)
+
+(define-instruction mtcrf (segment mask rt)
+  (:printer xfx-fxm ((op 31) (xo 144)))
+  (:delay 1)
+  (:dependencies (reads rt) (writes :ccr))
+  (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash mask 1) 144 0)))
+
+(define-x-5-st-instruction stwcx. 31 150 t :other-dependencies ((writes :ccr)))
+(define-x-5-st-instruction stwx 31 151 nil)
+(define-x-5-st-instruction stwux 31 183 nil :other-dependencies ((writes ra)))
+(define-4-xo-a-instructions subfze 31 200 :always-reads-xer t :always-writes-xer t)
+(define-4-xo-a-instructions addze 31 202 :always-reads-xer t :always-writes-xer t)
+(define-x-5-st-instruction stbx 31 215 nil)
+(define-4-xo-a-instructions subfme 31 232 :always-reads-xer t :always-writes-xer t)
+(define-4-xo-a-instructions addme 31 234 :always-reads-xer t :always-writes-xer t)
+(define-4-xo-instructions mullw 31 235 :cost 5)
+(define-x-5-st-instruction stbux 31 247 nil :other-dependencies ((writes ra)))
+(define-4-xo-instructions add 31 266)
+(define-x-instruction lhzx 31 279)
+(define-2-x-5-instructions eqv 31 284)
+(define-x-instruction lhzux 31 311 :other-dependencies ((writes ra)))
+(define-2-x-5-instructions xor 31 316)
+
+(define-instruction mfmq (segment rt)
+  (:printer xfx ((op 31) (xo 339) (spr 0)) '(:name :tab rt))
+  (:delay 1)
+  (:dependencies (reads :xer) (writes rt))
+  (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 339 0)))
+
+(define-instruction mfxer (segment rt)
+  (:printer xfx ((op 31) (xo 339) (spr 1)) '(:name :tab rt))
+  (:delay 1)
+  (:dependencies (reads :xer) (writes rt))
+  (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 339 0)))
+
+(define-instruction mflr (segment rt)
+  (:printer xfx ((op 31) (xo 339) (spr 8)) '(:name :tab rt))
+  (:delay 1)
+  (:dependencies (reads :lr) (writes rt))
+  (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 339 0)))
+
+(define-instruction mfctr (segment rt)
+  (:printer xfx ((op 31) (xo 339) (spr 9)) '(:name :tab rt))
+  (:delay 1)
+  (:dependencies (reads rt) (reads :ctr))
+  (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 339 0)))
+
+
+(define-x-instruction lhax 31 343)
+(define-x-instruction lhaux 31 375 :other-dependencies ((writes ra)))
+(define-x-5-st-instruction sthx 31 407 nil)
+(define-2-x-5-instructions orc 31 412)
+(define-x-5-st-instruction sthux 31 439 nil :other-dependencies ((writes ra)))
+
+(define-instruction or (segment ra rs rb)
+  (:printer x-5 ((op 31) (xo 444) (rc 0)) '((:cond
+                                             ((rs :same-as rb) 'mr)
+                                             (t :name))
+                                            :tab
+                                            ra "," rs
+                                            (:unless (:same-as rs) "," rb)))
+  (:delay 1)
+  (:cost 1)
+  (:dependencies (reads rb) (reads rs) (writes ra))
+  (:emitter
+   (emit-x-form-inst segment
+                     31
+                     (reg-tn-encoding rs) 
+                     (reg-tn-encoding ra)
+                     (reg-tn-encoding rb)
+                     444
+                     0)))
+
+(define-instruction or. (segment ra rs rb)
+  (:printer x-5 ((op 31) (xo 444) (rc 1)) '((:cond
+                                             ((rs :same-as rb) 'mr.)
+                                             (t :name))
+                                            :tab
+                                            ra "," rs
+                                            (:unless (:same-as rs) "," rb)))
+  (:delay 1)
+  (:cost 1)
+  (:dependencies (reads rb) (reads rs) (writes ra))
+  (:emitter
+   (emit-x-form-inst segment
+                     31
+                     (reg-tn-encoding rs) 
+                     (reg-tn-encoding ra)
+                     (reg-tn-encoding rb)
+                     444
+                     1)))
+
+(define-instruction-macro mr (ra rs)
+  `(inst or ,ra ,rs ,rs))
+
+(define-instruction-macro mr. (ra rs)
+  `(inst or. ,ra ,rs ,rs))
+
+(define-4-xo-instructions divwu 31 459 :cost 36)
+
+; This is a 601-specific instruction class.
+(define-4-xo-instructions div 31 331 :cost 36)
+
+; This is a 601-specific instruction.
+(define-instruction mtmq (segment rt)
+  (:printer xfx ((op 31) (xo 467) (spr (ash 0 5))) '(:name :tab rt))
+  (:delay 1)
+  (:dependencies (reads rt) (writes :xer))
+  (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 467 0)))
+
+(define-instruction mtxer (segment rt)
+  (:printer xfx ((op 31) (xo 467) (spr (ash 1 5))) '(:name :tab rt))
+  (:delay 1)
+  (:dependencies (reads rt) (writes :xer))
+  (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 467 0)))
+
+(define-instruction mtlr (segment rt)
+  (:printer xfx ((op 31) (xo 467) (spr (ash 8 5))) '(:name :tab rt))
+  (:delay 1)
+  (:dependencies (reads rt) (writes :lr))
+  (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 467 0)))
+
+(define-instruction mtctr (segment rt)
+  (:printer xfx ((op 31) (xo 467) (spr (ash 9 5))) '(:name :tab rt))
+  (:delay 1)
+  (:dependencies (reads rt) (writes :ctr))
+  (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 467 0)))
+
+
+(define-2-x-5-instructions nand 31 476)
+(define-4-xo-instructions divw 31 491 :cost 36)
+(define-instruction mcrxr (segment crf)
+  (:printer x-18 ((op 31) (xo 512)))
+  (:delay 1)
+  (:dependencies (reads :xer) (writes :ccr) (writes :xer))
+  (:emitter (emit-x-form-inst segment 31 (valid-cr-field-encoding crf) 0 0 512 0)))
+
+(define-instruction lswx (segment rs ra rb) 
+  (:printer x ((op 31) (xo 533) (rc 0)))
+  (:delay 1)
+  :pinned
+  (:cost 8) 
+  (:emitter (emit-x-form-inst new-assem:segment 31 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) 533 0)))
+(define-x-instruction lwbrx 31 534)
+(define-x-20-instruction lfsx 31 535)
+(define-2-x-5-instructions srw 31 536)
+(define-x-20-instruction lfsux 31 567 :other-dependencies ((writes ra)))
+
+(define-instruction lswi (segment rt ra rb) 
+  (:printer x-1 ((op 31) (xo 597) (rc 0)))
+  :pinned
+  (:delay 8)
+  (:cost 8) 
+  (:emitter (emit-x-form-inst new-assem:segment 31 (reg-tn-encoding rt) (reg-tn-encoding ra) rb 597 0)))
+
+(define-instruction sync (segment)
+  (:printer x-27 ((op 31) (xo 598)))
+  (:delay 1)
+  :pinned
+  (:emitter (emit-x-form-inst segment 31 0 0 0 598 0)))
+(define-x-20-instruction lfdx 31 599)
+(define-x-20-instruction lfdux 31 631 :other-dependencies ((writes ra)))
+(define-instruction stswx (segment rs ra rb) 
+  (:printer x-5 ((op 31) (xo 661)))
+  :pinned
+  (:cost 8) 
+  (:delay 1)
+  (:emitter (emit-x-form-inst new-assem:segment 31 
+                              (reg-tn-encoding rs) 
+                              (reg-tn-encoding ra) 
+                              (reg-tn-encoding rb) 
+                              661 
+                              0)))
+(define-x-5-st-instruction stwbrx 31 662 nil)
+(define-x-23-st-instruction stfsx 31 663)
+(define-x-23-st-instruction stfsux 31 695 :other-dependencies ((writes ra)))
+(define-instruction stswi (segment rs ra nb)
+  (:printer x-8 ((op 31) (xo 725)))
+  :pinned
+  (:delay 1)
+  (:emitter
+   (emit-x-form-inst segment 31
+                     (reg-tn-encoding rs) 
+                     (reg-tn-encoding ra)
+                     nb
+                     725
+                     0)))
+
+(define-x-23-st-instruction stfdx 31 727)
+(define-x-23-st-instruction stfdux 31 759 :other-dependencies ((writes ra)))
+(define-x-instruction lhbrx 31 790)
+(define-2-x-5-instructions sraw 31 792)
+
+(define-instruction srawi (segment ra rs rb)
+  (:printer x-9 ((op 31) (xo 824) (rc 0)))
+  (:cost 1)
+  (:delay 1)
+  (:dependencies (reads rs) (writes ra))
+  (:emitter
+   (emit-x-form-inst segment 31
+                        (reg-tn-encoding rs) 
+                        (reg-tn-encoding ra)
+                        rb
+                        824
+                        0)))
+
+(define-instruction srawi. (segment ra rs rb)
+  (:printer x-9 ((op 31) (xo 824) (rc 1)))
+  (:cost 1)
+  (:delay 1)
+  (:dependencies (reads rs) (writes ra))
+  (:emitter
+   (emit-x-form-inst segment 31
+                        (reg-tn-encoding rs) 
+                        (reg-tn-encoding ra)
+                        rb
+                        824
+                        1)))
+
+(define-instruction eieio (segment)
+  (:printer x-27 ((op 31) (xo 854)))
+  :pinned
+  (:delay 1)
+  (:emitter (emit-x-form-inst segment 31 0 0 0 854 0)))
+
+(define-x-5-st-instruction sthbrx 31 918 nil)
+
+
+(define-2-x-10-instructions extsb 31 954)
+(define-2-x-10-instructions extsh 31 922)
+; Whew.
+
+(define-instruction lwz (segment rt ra si)
+  (:declare (type (or fixup (signed-byte 16)) si))
+  (:printer d ((op 32)))
+  (:delay 2)
+  (:cost 2)
+  (:dependencies (reads ra) (writes rt))
+  (:emitter
+   (when (typep si 'fixup)
+     (note-fixup segment :l si)
+     (setq si 0))
+   (emit-d-form-inst segment 32 (reg-tn-encoding rt) (reg-tn-encoding ra) si)))
+
+(define-d-instruction lwzu 33 :other-dependencies ((writes ra)))
+(define-d-instruction lbz 34)
+(define-d-instruction lbzu 35 :other-dependencies ((writes ra)))
+(define-d-rs-instruction stw 36)
+(define-d-rs-instruction stwu 37 :other-dependencies ((writes ra)))
+(define-d-rs-instruction stb 38)
+(define-d-rs-instruction stbu 39 :other-dependencies ((writes ra)))
+(define-d-instruction lhz 40)
+(define-d-instruction lhzu 41 :other-dependencies ((writes ra)))
+(define-d-instruction lha 42)
+(define-d-instruction lhau 43 :other-dependencies ((writes ra)))
+(define-d-rs-instruction sth 44)
+(define-d-rs-instruction sthu 45 :other-dependencies ((writes ra)))
+(define-d-instruction lmw 46 :pinned t)
+(define-d-rs-instruction stmw 47 :pinned t)
+(define-d-frt-instruction lfs 48)
+(define-d-frt-instruction lfsu 49 :other-dependencies ((writes ra)))
+(define-d-frt-instruction lfd 50)
+(define-d-frt-instruction lfdu 51 :other-dependencies ((writes ra)))
+(define-d-frs-instruction stfs 52)
+(define-d-frs-instruction stfsu 53 :other-dependencies ((writes ra)))
+(define-d-frs-instruction stfd 54)
+(define-d-frs-instruction stfdu 55 :other-dependencies ((writes ra)))
+
+(define-2-a-tab-instructions fdivs 59 18 :cost 17)
+(define-2-a-tab-instructions fsubs 59 20)
+(define-2-a-tab-instructions fadds 59 21)
+(define-2-a-tac-instructions fmuls 59 25)
+(define-2-a-instructions fmsubs 59 28 :cost 4)
+(define-2-a-instructions fmadds 59 29 :cost 4)
+(define-2-a-instructions fnmsubs 59 30 :cost 4)
+(define-2-a-instructions fnmadds 59 31 :cost 4)
+
+(define-instruction fcmpu (segment crfd fra frb)
+  (:printer x-15 ((op 63) (xo 0)))
+  (:dependencies (reads fra) (reads frb) (reads :fpscr) 
+                 (writes :fpscr) (writes :ccr))
+  (:cost 4)
+  (:delay 4)
+  (:emitter (emit-x-form-inst segment 
+                          63 
+                          (valid-cr-field-encoding crfd)
+                          (fp-reg-tn-encoding fra) 
+                          (fp-reg-tn-encoding frb)
+                          0
+                          0)))
+
+
+(define-2-x-21-instructions frsp 63 12)
+(define-2-x-21-instructions fctiw 63 14)
+(define-2-x-21-instructions fctiwz 63 15)
+
+(define-2-a-tab-instructions fdiv 63 18 :cost 31)
+(define-2-a-tab-instructions fsub 63 20)
+(define-2-a-tab-instructions fadd 63 21)
+(define-2-a-tac-instructions fmul 63 25 :cost 5)
+(define-2-a-instructions fmsub 63 28 :cost 5)
+(define-2-a-instructions fmadd 63 29 :cost 5)
+(define-2-a-instructions fnmsub 63 30 :cost 5)
+(define-2-a-instructions fnmadd 63 31 :cost 5)
+
+(define-instruction fcmpo (segment crfd fra frb)
+  (:printer x-15 ((op 63) (xo 32)))
+  (:dependencies (reads fra) (reads frb) (reads :fpscr) 
+                 (writes :fpscr) (writes :ccr))
+  (:cost 4)
+  (:delay 1)
+  (:emitter (emit-x-form-inst segment 
+                          63 
+                          (valid-cr-field-encoding crfd)
+                          (fp-reg-tn-encoding fra) 
+                          (fp-reg-tn-encoding frb)
+                          32
+                          0)))
+
+(define-2-x-21-instructions fneg 63 40)
+
+(define-2-x-21-instructions fmr 63 72)
+(define-2-x-21-instructions fnabs 63 136)
+(define-2-x-21-instructions fabs 63 264)
+
+(define-instruction mffs (segment frd)
+  (:printer x-22 ((op 63)  (xo 583) (rc 0)))
+  (:delay 1)
+  (:dependencies (reads :fpscr) (writes frd))
+  (:emitter (emit-x-form-inst segment 
+                          63 
+                          (fp-reg-tn-encoding frd)
+                          0 
+                          0
+                          583
+                          0)))
+
+(define-instruction mffs. (segment frd)
+  (:printer x-22 ((op 63)  (xo 583) (rc 1)))
+  (:delay 1)
+  (:dependencies (reads :fpscr) (writes frd))
+  (:emitter (emit-x-form-inst segment 
+                          63 
+                          (fp-reg-tn-encoding frd)
+                          0 
+                          0
+                          583
+                          1)))
+
+(define-instruction mtfsf (segment mask rb)
+  (:printer xfl ((op 63) (xo 711) (rc 0)))
+  (:dependencies (reads rb) (writes :fpscr))
+  (:delay 1)
+  (:emitter (emit-xfl-form-inst segment 63  (ash mask 1) (fp-reg-tn-encoding rb) 711 0)))
+
+(define-instruction mtfsf. (segment mask rb)
+  (:printer xfl ((op 63) (xo 711) (rc 1)))
+  (:delay 1)
+  (:dependencies (reads rb) (writes :ccr) (writes :fpscr))
+  (:emitter (emit-xfl-form-inst segment 63  (ash mask 1) (fp-reg-tn-encoding rb) 711 1)))
+
+
+
+
+;;; Here in the future, macros are our friends.
+
+(define-instruction-macro subis (rt ra simm)
+  `(inst addis ,rt ,ra (- ,simm)))
+
+(define-instruction-macro sub (rt rb ra)
+  `(inst subf ,rt ,ra ,rb))
+(define-instruction-macro sub. (rt rb ra)
+  `(inst subf. ,rt ,ra ,rb))
+(define-instruction-macro subo (rt rb ra)
+  `(inst subfo ,rt ,ra ,rb))
+(define-instruction-macro subo. (rt rb ra)
+  `(inst subfo. ,rt ,ra ,rb))
+
+
+(define-instruction-macro subic (rt ra simm)
+  `(inst addic ,rt ,ra (- ,simm)))
+
+
+(define-instruction-macro subic. (rt ra simm)
+  `(inst addic. ,rt ,ra (- ,simm)))
+
+
+
+(define-instruction-macro subc (rt rb ra)
+  `(inst subfc ,rt ,ra ,rb))
+(define-instruction-macro subc. (rt rb ra)
+  `(inst subfc. ,rt ,ra ,rb))
+(define-instruction-macro subco (rt rb ra)
+  `(inst subfco ,rt ,ra ,rb))
+(define-instruction-macro subco. (rt rb ra)
+  `(inst subfco. ,rt ,ra ,rb))
+
+(define-instruction-macro subi (rt ra simm)
+  `(inst addi ,rt ,ra (- ,simm)))
+
+(define-instruction-macro li (rt val)
+  `(inst addi ,rt zero-tn ,val))
+
+(define-instruction-macro lis (rt val)
+  `(inst addis ,rt zero-tn ,val))
+
+
+(define-instruction-macro not (ra rs)
+  `(inst nor ,ra ,rs ,rs))
+
+(define-instruction-macro not. (ra rs)
+  `(inst nor. ,ra ,rs ,rs))
+
+
+(def-vm-support-routine emit-nop (segment)
+  (emit-word segment #x60000000))
+
+(define-instruction-macro extlwi (ra rs n b)
+  `(inst rlwinm ,ra ,rs ,b 0 (1- ,n)))
+
+(define-instruction-macro extlwi. (ra rs n b)
+  `(inst rlwinm. ,ra ,rs ,b 0 (1- ,n)))
+
+(define-instruction-macro srwi (ra rs n)
+  `(inst rlwinm ,ra ,rs (- 32 ,n) ,n 31))
+
+(define-instruction-macro srwi. (ra rs n)
+  `(inst rlwinm. ,ra ,rs (- 32 ,n) ,n 31))
+
+(define-instruction-macro clrrwi (ra rs n)
+  `(inst rlwinm ,ra ,rs 0 0 (- 31 ,n)))
+
+(define-instruction-macro clrrwi. (ra rs n)
+  `(inst rlwinm. ,ra ,rs 0 0 (- 31 ,n)))
+
+(define-instruction-macro inslw (ra rs n b)
+  `(inst rlwimi ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n))))
+
+(define-instruction-macro inslw. (ra rs n b)
+  `(inst rlwimi. ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n))))
+
+(define-instruction-macro rotlw (ra rs rb)
+  `(inst rlwnm ,ra ,rs ,rb 0 31))
+
+(define-instruction-macro rotlw. (ra rs rb)
+  `(inst rlwnm. ,ra ,rs ,rb 0 31))
+
+(define-instruction-macro slwi (ra rs n)
+  `(inst rlwinm ,ra ,rs ,n 0 (- 31 ,n)))
+
+(define-instruction-macro slwi. (ra rs n)
+  `(inst rlwinm. ,ra ,rs ,n 0 (- 31 ,n)))
+
+
+
+
+#|
+(macrolet 
+  ((define-conditional-branches (name bo-name)
+     (let* ((bo-enc (valid-bo-encoding bo-name)))
+       `(progn
+          (define-instruction-macro ,(symbolicate name "A") (bi target)
+            ``(inst bca ,,,bo-enc ,,bi ,,target))
+          (define-instruction-macro ,(symbolicate name "L") (bi target)
+            ``(inst bcl ,,,bo-enc ,,bi ,,target))
+          (define-instruction-macro ,(symbolicate name "LA") (bi target)
+            ``(inst bcla ,,,bo-enc ,,bi ,,target))
+          (define-instruction-macro ,(symbolicate name "CTR") (bi target)
+            ``(inst bcctr ,,,bo-enc ,,bi ,,target))
+          (define-instruction-macro ,(symbolicate name "CTRL") (bi target)
+            ``(inst bcctrl ,,,bo-enc ,,bi ,,target))
+          (define-instruction-macro ,(symbolicate name "LR") (bi target)
+            ``(inst bclr ,,,bo-enc ,,bi ,,target))
+          (define-instruction-macro ,(symbolicate name "LRL") (bi target)
+            ``(inst bclrl ,,,bo-enc ,,bi ,,target))))))
+  (define-conditional-branches bt :bo-t)
+  (define-conditional-branches bf :bo-f))
+|#
+
+(macrolet 
+  ((define-positive-conditional-branches (name cr-bit-name)
+     `(progn
+        (define-instruction-macro ,name (crf &optional (target nil target-p))
+          (unless target-p
+            (setq target crf crf :cr0))
+          `(inst bt `(,,crf ,,,cr-bit-name) ,target))
+#|
+        (define-instruction-macro ,(symbolicate name "A") (target &optional (cr-field :cr0))
+          ``(inst bta (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "L") (target &optional (cr-field :cr0))
+          ``(inst btl (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "LA") (target &optional (cr-field :cr0))
+          ``(inst btla (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "CTR") (target &optional (cr-field :cr0))
+          ``(inst btctr (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "CTRL") (target &optional (cr-field :cr0))
+          ``(inst btctrl (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "LR") (target &optional (cr-field :cr0))
+          ``(inst btlr (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "LRL") (target &optional (cr-field :cr0))
+          ``(inst btlrl (,,cr-field ,,,cr-bit-name) ,,target))
+|#
+        )))
+  (define-positive-conditional-branches beq :eq)
+  (define-positive-conditional-branches blt :lt)
+  (define-positive-conditional-branches bgt :gt)
+  (define-positive-conditional-branches bso :so)
+  (define-positive-conditional-branches bun :so))
+
+(macrolet 
+  ((define-negative-conditional-branches (name cr-bit-name)
+     `(progn
+        (define-instruction-macro ,name (crf &optional (target nil target-p))
+          (unless target-p
+            (setq target crf crf :cr0))
+          `(inst bf `(,,crf ,,,cr-bit-name) ,target))
+#|
+        (define-instruction-macro ,(symbolicate name "A") (target &optional (cr-field :cr0))
+          ``(inst bfa (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "L") (target &optional (cr-field :cr0))
+          ``(inst bfl (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "LA") (target &optional (cr-field :cr0))
+          ``(inst bfla (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "CTR") (target &optional (cr-field :cr0))
+          ``(inst bfctr (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "CTRL") (target &optional (cr-field :cr0))
+          ``(inst bfctrl (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "LR") (target &optional (cr-field :cr0))
+          ``(inst bflr (,,cr-field ,,,cr-bit-name) ,,target))
+        (define-instruction-macro ,(symbolicate name "LRL") (target &optional (cr-field :cr0))
+          ``(inst bflrl (,,cr-field ,,,cr-bit-name) ,,target))
+|#
+)))
+  (define-negative-conditional-branches bne :eq)
+  (define-negative-conditional-branches bnl :lt)
+  (define-negative-conditional-branches bge :lt)
+  (define-negative-conditional-branches bng :gt)
+  (define-negative-conditional-branches ble :gt)
+  (define-negative-conditional-branches bns :so)
+  (define-negative-conditional-branches bnu :so))
+
+
+
+(define-instruction-macro j (func-tn offset)
+  `(progn
+     (inst addi lip-tn ,func-tn ,offset)
+     (inst mtctr lip-tn)
+     (inst bctr)))
+
+
+#|
+(define-instruction-macro bua (target)
+  `(inst bca :bo-u 0 ,target))
+
+(define-instruction-macro bul (target)
+  `(inst bcl :bo-u 0 ,target))
+
+(define-instruction-macro bula (target)
+  `(inst bcla :bo-u 0 ,target))
+
+
+(define-instruction-macro blrl ()
+  `(inst bclrl :bo-u 0))
+
+
+
+|#
+
+
+
+
+
+;;; Some more macros 
+
+(defun %lr (reg value)
+  (etypecase value
+    ((signed-byte 16)
+     (inst li reg value))
+    ((unsigned-byte 16)
+     (inst ori reg zero-tn value))
+    ((or (signed-byte 32) (unsigned-byte 32))
+     (let* ((high-half (ldb (byte 16 16) value))
+            (low-half (ldb (byte 16 0) value)))
+       (declare (type (unsigned-byte 16) high-half low-half))
+       (cond ((if (logbitp 15 low-half) (= high-half #xffff) (zerop high-half))
+              (inst li reg low-half))
+             (t
+              (inst lis reg high-half)
+              (unless (zerop low-half)
+                (inst ori reg reg low-half))))))
+    (fixup
+     (inst lis reg value)
+     (inst addi reg reg value))))
+
+(define-instruction-macro lr (reg value)
+  `(%lr ,reg ,value))
+     
+
+
+;;;; Instructions for dumping data and header objects.
+
+(define-instruction word (segment word)
+  (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
+  :pinned
+  (:delay 0)
+  (:emitter
+   (emit-word segment word)))
+
+(define-instruction short (segment short)
+  (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
+  :pinned
+  (:delay 0)
+  (:emitter
+   (emit-short segment short)))
+
+(define-instruction byte (segment byte)
+  (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
+  :pinned
+  (:delay 0)
+  (:emitter
+   (emit-byte segment byte)))
+
+(define-emitter emit-header-object 32
+  (byte 24 8) (byte 8 0))
+
+(defun emit-header-data (segment type)
+  (emit-back-patch
+   segment 4
+   #'(lambda (segment posn)
+       (emit-word segment
+		  (logior type
+			  (ash (+ posn (component-header-length))
+			       (- type-bits word-shift)))))))
+
+(define-instruction function-header-word (segment)
+  :pinned
+  (:delay 0)
+  (:emitter
+   (emit-header-data segment function-header-type)))
+
+(define-instruction lra-header-word (segment)
+  :pinned
+  (:delay 0)
+  (:emitter
+   (emit-header-data segment return-pc-header-type)))
+
+
+;;;; Instructions for converting between code objects, functions, and lras.
+(defun emit-compute-inst (segment vop dst src label temp calc)
+  (emit-chooser
+   ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
+   segment 12 3
+   #'(lambda (segment posn delta-if-after)
+       (let ((delta (funcall calc label posn delta-if-after)))
+	 (when (<= (- (ash 1 16)) delta (1- (ash 1 16)))
+	   (emit-back-patch segment 4
+			    #'(lambda (segment posn)
+				(assemble (segment vop)
+					  (inst addi dst src
+						(funcall calc label posn 0)))))
+	   t)))
+   #'(lambda (segment posn)
+       (let ((delta (funcall calc label posn 0)))
+	 (assemble (segment vop)
+		   (inst lis temp (ldb (byte 16 16) delta))
+		   (inst ori temp temp (ldb (byte 16 0) delta))
+		   (inst add dst src temp))))))
+
+;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag
+(define-instruction compute-code-from-fn (segment dst src label temp)
+  (:declare (type tn dst src temp) (type label label))
+  (:attributes variable-length)
+  (:dependencies (reads src) (writes dst) (writes temp))
+  (:delay 0)
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop dst src label temp
+		      #'(lambda (label posn delta-if-after)
+			  (- other-pointer-type
+			     function-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 dst src label temp)
+  (:declare (type tn dst src temp) (type label label))
+  (:attributes variable-length)
+  (:dependencies (reads src) (writes dst) (writes temp))
+  (:delay 0)
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop dst src label temp
+		      #'(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 dst src label temp)
+  (:declare (type tn dst src temp) (type label label))
+  (:attributes variable-length)
+  (:dependencies (reads src) (writes dst) (writes temp))
+  (:delay 0)
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop dst src label temp
+		      #'(lambda (label posn delta-if-after)
+			  (+ (label-position label posn delta-if-after)
+			     (component-header-length))))))
diff --git a/compiler/ppc/macros.lisp b/compiler/ppc/macros.lisp
new file mode 100644
index 000000000..35f7a64f4
--- /dev/null
+++ b/compiler/ppc/macros.lisp
@@ -0,0 +1,454 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice 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 Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/macros.lisp,v 1.1 2001/02/11 14:22:04 dtc Exp $
+;;;
+;;; This file contains various useful macros for generating PC code.
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "PPC")
+
+
+;;; Instruction-like macros.
+
+(defmacro move (dst src)
+  "Move SRC into DST unless they are location=."
+  (once-only ((n-dst dst)
+	      (n-src src))
+    `(unless (location= ,n-dst ,n-src)
+       (inst mr ,n-dst ,n-src))))
+
+(macrolet
+    ((frob (op inst shift)
+       `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
+	  `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
+  (frob loadw lwz word-shift)
+  (frob storew stw word-shift))
+
+(defmacro load-symbol (reg symbol)
+  `(inst addi ,reg null-tn (static-symbol-offset ,symbol)))
+
+(macrolet
+    ((frob (slot)
+       (let ((loader (intern (concatenate 'simple-string
+					  "LOAD-SYMBOL-"
+					  (string slot))))
+	     (storer (intern (concatenate 'simple-string
+					  "STORE-SYMBOL-"
+					  (string slot))))
+	     (offset (intern (concatenate 'simple-string
+					  "SYMBOL-"
+					  (string slot)
+					  "-SLOT")
+			     (find-package "VM"))))
+	 `(progn
+	    (defmacro ,loader (reg symbol)
+	      `(inst lwz ,reg null-tn
+		     (+ (static-symbol-offset ',symbol)
+			(ash ,',offset word-shift)
+			(- other-pointer-type))))
+	    (defmacro ,storer (reg symbol)
+	      `(inst stw ,reg null-tn
+		     (+ (static-symbol-offset ',symbol)
+			(ash ,',offset word-shift)
+			(- other-pointer-type))))))))
+  (frob value)
+  (frob function))
+
+(defmacro load-type (target source &optional (offset 0))
+  "Loads the type bits of a pointer into target independent of
+  byte-ordering issues."
+  (once-only ((n-target target)
+	      (n-source source)
+	      (n-offset offset))
+    (ecase (backend-byte-order *target-backend*)
+      (:little-endian
+       `(inst lbz ,n-target ,n-source ,n-offset))
+      (:big-endian
+       `(inst lbz ,n-target ,n-source (+ ,n-offset 3))))))
+
+;;; 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."
+  `(progn
+     (inst mtctr ,function)
+     (move code-tn ,function)
+     (inst bctr)))
+
+(defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
+  "Return to RETURN-PC."
+  `(progn
+     (inst addi lip-tn ,return-pc (- (* (1+ ,offset) word-bytes) other-pointer-type))
+     (inst mtlr lip-tn)
+     ,@(if frob-code
+         `((move code-tn ,return-pc)))
+     (inst blr)))
+
+(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-reg ,n-stack))
+	  ((control-stack)
+	   (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
+
+
+;;;; Storage allocation:
+
+(defmacro with-fixed-allocation ((result-tn flag-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) (flag-tn flag-tn)
+	      (type-code type-code) (size size))
+    `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
+       (inst ori ,result-tn alloc-tn other-pointer-type)
+       (inst lr ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
+       (storew ,temp-tn ,result-tn 0 other-pointer-type)
+       ,@body)))
+
+
+;;;; Type testing noise.
+
+;;; GEN-RANGE-TEST -- internal
+;;;
+;;; Generate code that branches to TARGET iff REG contains one of VALUES.
+;;; If NOT-P is true, invert the test.  Jumping to NOT-TARGET is the same
+;;; as falling out the bottom.
+;;; 
+(defun gen-range-test (reg target not-target not-p min seperation max values)
+  (let ((tests nil)
+	(start nil)
+	(end nil)
+	(insts nil))
+    (multiple-value-bind (equal less-or-equal greater-or-equal label)
+			 (if not-p
+			     (values :ne :gt :lt not-target)
+			     (values :eq :le :ge target))
+      (flet ((emit-test ()
+	       (if (= start end)
+		   (push start tests)
+		   (push (cons start end) tests))))
+	(dolist (value values)
+	  (cond ((< value min)
+		 (error "~S is less than the specified minimum of ~S"
+			value min))
+		((> value max)
+		 (error "~S is greater than the specified maximum of ~S"
+			value max))
+		((not (zerop (rem (- value min) seperation)))
+		 (error "~S isn't an even multiple of ~S from ~S"
+			value seperation min))
+		((null start)
+		 (setf start value))
+		((> value (+ end seperation))
+		 (emit-test)
+		 (setf start value)))
+	  (setf end value))
+	(emit-test))
+      (macrolet ((inst (name &rest args)
+		       `(push (list 'inst ',name ,@args) insts)))
+	(do ((remaining (nreverse tests) (cdr remaining)))
+	    ((null remaining))
+	  (let ((test (car remaining))
+		(last (null (cdr remaining))))
+	    (if (atom test)
+		(progn
+		  (inst cmpwi reg test)
+		  (if last
+		      (inst b? equal target)
+		      (inst beq label)))
+		(let ((start (car test))
+		      (end (cdr test)))
+		  (cond ((and (= start min) (= end max))
+			 (warn "The values ~S cover the entire range from ~
+			 ~S to ~S [step ~S]."
+			       values min max seperation)
+			 (push `(unless ,not-p (inst b ,target)) insts))
+			((= start min)
+			 (inst cmpwi reg end)
+			 (if last
+			     (inst b? less-or-equal target)
+			     (inst ble label)))
+			((= end max)
+			 (inst cmpwi reg start)
+			 (if last
+			     (inst b? greater-or-equal target)
+			     (inst bge label)))
+			(t
+			 (inst cmpwi reg start)
+			 (inst blt (if not-p target not-target))
+			 (inst cmpwi reg end)
+			 (if last
+			     (inst b? less-or-equal target)
+			     (inst ble label))))))))))
+    (nreverse insts)))
+
+(defun gen-other-immediate-test (reg target not-target not-p values)
+  (gen-range-test reg target not-target not-p
+		  (+ other-immediate-0-type lowtag-limit)
+		  (- other-immediate-1-type other-immediate-0-type)
+		  (ash 1 type-bits)
+		  values))
+
+
+(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
+			  function-p)
+  (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql)
+		       (member odd-fixnum-type lowtags :test #'eql)))
+	 (lowtags (sort (if fixnump
+			    (delete even-fixnum-type
+				    (remove odd-fixnum-type lowtags
+					    :test #'eql)
+				    :test #'eql)
+			    (copy-list lowtags))
+			#'<))
+	 (lowtag (if function-p
+		     vm:function-pointer-type
+		     vm:other-pointer-type))
+	 (hdrs (sort (copy-list hdrs) #'<))
+	 (immed (sort (copy-list immed) #'<)))
+    (append
+     (when immed
+       `((inst andi. ,temp ,reg type-mask)
+	 ,@(if (or fixnump lowtags hdrs)
+	       (let ((fall-through (gensym)))
+		 `((let (,fall-through (gen-label))
+		     ,@(gen-other-immediate-test
+			temp (if not-p not-target target)
+			fall-through nil immed)
+		     (emit-label ,fall-through))))
+	       (gen-other-immediate-test temp target not-target not-p immed))))
+     (when fixnump
+       `((inst andi. ,temp ,reg 3)
+	 ,(if (or lowtags hdrs)
+	      `(inst beq ,(if not-p not-target target))
+	      `(inst b? ,(if not-p :ne :eq) ,target))))
+     (when (or lowtags hdrs)
+       `((inst andi. ,temp ,reg lowtag-mask)))
+     (when lowtags
+       (if hdrs
+	   (let ((fall-through (gensym)))
+	     `((let ((,fall-through (gen-label)))
+		 ,@(gen-range-test temp (if not-p not-target target)
+				   fall-through nil
+				   0 1 (1- lowtag-limit) lowtags)
+		 (emit-label ,fall-through))))
+	   (gen-range-test temp target not-target not-p 0 1
+			   (1- lowtag-limit) lowtags)))
+     (when hdrs
+       `((inst cmpwi ,temp ,lowtag)
+	 (inst bne ,(if not-p target not-target))
+	 (load-type ,temp ,reg (- ,lowtag))
+	 ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
+
+(defconstant immediate-types
+  (list base-char-type unbound-marker-type))
+
+(defconstant function-subtypes
+  (list funcallable-instance-header-type
+	function-header-type closure-function-header-type
+	closure-header-type))
+
+(defmacro test-type (register temp target not-p &rest type-codes)
+  (let* ((type-codes (mapcar #'eval type-codes))
+	 (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 nil))
+    (unless type-codes
+      (error "Must supply at least on type for test-type."))
+    (when (and headers (member other-pointer-type lowtags))
+      (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
+      (setf headers nil))
+    (when (and immediates
+	       (or (member other-immediate-0-type lowtags)
+		   (member other-immediate-1-type lowtags)))
+      (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
+      (setf immediates nil))
+    (when (intersection headers function-subtypes)
+      (unless (subsetp headers function-subtypes)
+	(error "Can't test for mix of function subtypes and normal ~
+		header types."))
+      (setq function-p t))
+      
+    (let ((n-reg (gensym))
+	  (n-temp (gensym))
+	  (n-target (gensym))
+	  (not-target (gensym)))
+      `(let ((,n-reg ,register)
+	     (,n-temp ,temp)
+	     (,n-target ,target)
+	     (,not-target (gen-label)))
+	 (declare (ignorable ,n-temp))
+	 ,@(if (constantp not-p)
+	       (test-type-aux n-reg n-temp n-target not-target
+			      (eval not-p) lowtags immediates headers
+			      function-p)
+	       `((cond (,not-p
+			,@(test-type-aux n-reg n-temp n-target not-target t
+					 lowtags immediates headers
+					 function-p))
+		       (t
+			,@(test-type-aux n-reg n-temp n-target not-target nil
+					 lowtags immediates headers
+					 function-p)))))
+	 (emit-label ,not-target)))))
+
+
+;;;; 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-toplevel :load-toplevel :execute)
+  (defun emit-error-break (vop kind code values)
+    (let ((vector (gensym)))
+      `((let ((vop ,vop))
+	  (when vop
+	    (note-this-location vop :internal-error)))
+	(inst unimp ,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
+     ,@(emit-error-break vop cerror-trap error-code values)
+     (inst b ,label)))
+
+(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.
+;;;
+;;; flag-tn must be wired to NL3. If a deferred interrupt happens
+;;; while we have the low bits of alloc-tn set, we add a "large"
+;;; constant to flag-tn.  On exit, we add flag-tn to alloc-tn
+;;; which (a) aligns alloc-tn again and (b) makes alloc-tn go
+;;; negative.  We then trap if alloc-tn's negative (handling the
+;;; deferred interrupt) and using flag-tn - minus the large constant -
+;;; to correct alloc-tn.
+(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
+  (let ((n-extra (gensym)))
+    `(let ((,n-extra ,extra))
+       (without-scheduling ()
+	;; Extra debugging stuff:
+	#+debug
+	(progn
+	  (inst andi. ,flag-tn alloc-tn 7)
+	  (inst twi :ne ,flag-tn 0))
+	(inst lr ,flag-tn (- ,n-extra 4))
+	(inst addi alloc-tn alloc-tn 4))
+      ,@forms
+      (without-scheduling ()
+       (inst add alloc-tn alloc-tn ,flag-tn)
+       (inst twi :lt alloc-tn 0))
+      #+debug
+      (progn
+	(inst andi. ,flag-tn alloc-tn 7)
+	(inst twi :ne ,flag-tn 0)))))
diff --git a/compiler/ppc/memory.lisp b/compiler/ppc/memory.lisp
new file mode 100644
index 000000000..1bdab9775
--- /dev/null
+++ b/compiler/ppc/memory.lisp
@@ -0,0 +1,118 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/memory.lisp,v 1.1 2001/02/11 14:22:05 dtc Rel $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the PPC definitions of some general purpose memory
+;;; reference VOPs inherited by basic memory reference operations.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by William Lott.
+;;; 
+
+(in-package "PPC")
+
+;;; 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.
+;;;
+(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 4
+    (storew value object offset lowtag)))
+
+;;; 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 standard 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 4
+    (storew value object (+ base offset) lowtag)))
+
+
+
+;;;; Indexed references:
+
+;;; Define-Indexer  --  Internal
+;;;
+;;;    Define some VOPs for indexed memory reference.
+;;;
+(defmacro define-indexer (name write-p ri-op rr-op shift &optional sign-extend-byte)
+  `(define-vop (,name)
+     (:args (object :scs (descriptor-reg))
+	    (index :scs (any-reg zero immediate))
+	    ,@(when write-p
+		'((value :scs (any-reg descriptor-reg) :target result))))
+     (:arg-types * tagged-num ,@(when write-p '(*)))
+     (:temporary (:scs (non-descriptor-reg)) temp)
+     (:results (,(if write-p 'result 'value)
+		:scs (any-reg descriptor-reg)))
+     (:result-types *)
+     (:variant-vars offset lowtag)
+     (:policy :fast-safe)
+     (:generator 5
+       (sc-case index
+	 ((immediate zero)
+	  (let ((offset (- (+ (if (sc-is index zero)
+				  0
+				  (ash (tn-value index)
+				       (- vm:word-shift ,shift)))
+			      (ash offset vm:word-shift))
+			   lowtag)))
+	    (etypecase offset
+	      ((signed-byte 16)
+	       (inst ,ri-op value object offset))
+	      ((or (unsigned-byte 32) (signed-byte 32))
+	       (inst lr temp offset)
+	       (inst ,rr-op value object temp)))))
+	 (t
+	  ,@(unless (zerop shift)
+	      `((inst srwi temp index ,shift)))
+	  (inst addi temp ,(if (zerop shift) 'index 'temp)
+		(- (ash offset vm:word-shift) lowtag))
+	  (inst ,rr-op value object temp)))
+       ,@(when sign-extend-byte
+           `((inst extsb value value)))
+       ,@(when write-p
+	   '((move result value))))))
+
+(define-indexer word-index-ref nil lwz lwzx 0)
+(define-indexer word-index-set t stw stwx 0)
+(define-indexer halfword-index-ref nil lhz lhzx 1)
+(define-indexer signed-halfword-index-ref nil lha lhax 1)
+(define-indexer halfword-index-set t sth sthx 1)
+(define-indexer byte-index-ref nil lbz lbzx 2)
+(define-indexer signed-byte-index-ref nil lbz lbzx 2 t)
+(define-indexer byte-index-set t stb stbx 2)
+
diff --git a/compiler/ppc/move.lisp b/compiler/ppc/move.lisp
new file mode 100644
index 000000000..056ae77b0
--- /dev/null
+++ b/compiler/ppc/move.lisp
@@ -0,0 +1,317 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice 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 Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/move.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $
+;;;
+;;;    This file contains the SPARC VM definition of operand loading/saving and
+;;; the Move VOP.
+;;;
+;;; Written by Rob MacLachlan.
+;;; SPARC conversion by William Lott.
+;;;
+(in-package "PPC")
+
+
+(define-move-function (load-immediate 1) (vop x y)
+  ((null immediate zero)
+   (any-reg descriptor-reg))
+  (let ((val (tn-value x)))
+    (etypecase val
+      (integer
+       (inst lr y (fixnum val)))
+      (null
+       (move y null-tn))
+      (symbol
+       (load-symbol y val))
+      (character
+       (inst lr y (logior (ash (char-code val) type-bits)
+			  base-char-type))))))
+
+(define-move-function (load-number 1) (vop x y)
+  ((immediate zero)
+   (signed-reg unsigned-reg))
+  (inst lr y (tn-value x)))
+
+(define-move-function (load-base-char 1) (vop x y)
+  ((immediate) (base-char-reg))
+  (inst li y (char-code (tn-value x))))
+
+(define-move-function (load-system-area-pointer 1) (vop x y)
+  ((immediate) (sap-reg))
+  (inst lr y (sap-int (tn-value x))))
+
+(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 zero null)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (any-reg descriptor-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+
+(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 zero null))
+	 (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 y x))
+      (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 srawi y x 2)))
+;;;
+(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 lr y (tn-value x))))
+;;;
+(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")
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 4
+    (let ((done (gen-label)))
+      (inst andi. temp x 3)
+      (sc-case y
+	(signed-reg
+	 (inst srawi y x 2))
+	(unsigned-reg
+	 (inst srwi y x 2)))
+      
+      (inst beq done)
+      (loadw y x bignum-digits-offset other-pointer-type)
+      
+      (emit-label done))))
+;;;
+(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 slwi y x 2)))
+;;;
+(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 (arg :scs (signed-reg unsigned-reg) :target x))
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:note "signed word to integer coercion")
+  (:generator 20
+    (move x arg)
+    (let ((done (gen-label)))
+      (inst mcrxr :cr0)                 ; clear sticky overflow bits in XER, CR0
+      (inst addo temp x x)              ; set XER OV if top two bits differ
+      (inst addo. temp temp temp)       ; set CR0 SO if any top three bits differ
+      (inst slwi y x 2)                 ; assume fixnum (tagged ok, maybe lost some high bits)
+      (inst bns done)
+      
+      (with-fixed-allocation (y pa-flag temp bignum-type (1+ bignum-digits-offset))
+	(storew x y bignum-digits-offset other-pointer-type))
+      (emit-label 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 (arg :scs (signed-reg unsigned-reg) :target x))
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:note "unsigned word to integer coercion")
+  (:generator 20
+    (move x arg)
+    (let ((done (gen-label))
+	  (one-word (gen-label))
+	  (initial-alloc (pad-data-block (1+ bignum-digits-offset))))
+      (inst srawi. temp x 29)
+      (inst slwi y x 2)
+      (inst beq done)
+      
+      (pseudo-atomic (pa-flag :extra initial-alloc)
+	(inst cmpwi x 0)
+	(inst ori y alloc-tn other-pointer-type)
+	(inst li temp (logior (ash 1 type-bits) bignum-type))
+	(inst bge one-word)
+	(inst addi alloc-tn alloc-tn
+	      (- (pad-data-block (+ bignum-digits-offset 2))
+		 (pad-data-block (+ bignum-digits-offset 1))))
+	(inst li temp (logior (ash 2 type-bits) bignum-type))
+	(emit-label one-word)
+	(storew temp y 0 other-pointer-type)
+	(storew x y bignum-digits-offset other-pointer-type))
+      (emit-label 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 y x)))
+;;;
+(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 y x))
+      ((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/ppc/nlx.lisp b/compiler/ppc/nlx.lisp
new file mode 100644
index 000000000..b1789435d
--- /dev/null
+++ b/compiler/ppc/nlx.lisp
@@ -0,0 +1,279 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice 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 Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/nlx.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $
+;;;
+;;;    This file contains the definitions of VOPs used for non-local exit
+;;; (throw, lexical exit, etc.)
+;;;
+;;; Written by Rob MacLachlan
+;;;
+(in-package "PPC")
+
+;;; 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 nfp cur-nfp)))
+    (move nsp nsp-tn)
+    (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 cur-nfp nfp)))
+    (move nsp-tn nsp)))
+
+(define-vop (current-stack-pointer)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (move res csp-tn)))
+
+(define-vop (current-binding-pointer)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (move res bsp-tn)))
+
+
+
+;;;; 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 block cfp-tn (* (tn-offset tn) vm:word-bytes))
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp block vm:unwind-block-current-uwp-slot)
+    (storew cfp-tn block vm:unwind-block-current-cont-slot)
+    (storew code-tn block vm:unwind-block-current-code-slot)
+    (inst compute-lra-from-code temp code-tn entry-label ndescr)
+    (storew temp block vm: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)))
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:generator 44
+    (inst addi result cfp-tn (* (tn-offset tn) vm:word-bytes))
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp result vm:catch-block-current-uwp-slot)
+    (storew cfp-tn result vm:catch-block-current-cont-slot)
+    (storew code-tn result vm:catch-block-current-code-slot)
+    (inst compute-lra-from-code temp code-tn entry-label ndescr)
+    (storew temp result vm:catch-block-entry-pc-slot)
+
+    (storew tag result vm:catch-block-tag-slot)
+    (load-symbol-value temp lisp::*current-catch-block*)
+    (storew temp result vm:catch-block-previous-catch-slot)
+    (store-symbol-value result lisp::*current-catch-block*)
+
+    (move block result)))
+
+
+;;; 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 new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes))
+    (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 vm: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 vm: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)
+	   (let ((no-values (gen-label)))
+	     (inst cmpwi count 0)
+	     (move (tn-ref-tn values) null-tn)
+	     (inst beq no-values)
+	     (loadw (tn-ref-tn values) start)
+	     (emit-label no-values)))
+	  (t
+	   (collect ((defaults))
+	     (inst addic. count count (- (fixnum 1)))
+	     (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 subi count count (fixnum 1))
+		 (inst blt 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)))
+                 (inst cmpwi count 0)))
+	     
+	     (let ((defaulting-done (gen-label)))
+	       
+	       (emit-label defaulting-done)
+	       
+	       (assemble (*elsewhere*)
+		 (dolist (def (defaults))
+		   (emit-label (car def))
+		   (let ((tn (cdr def)))
+		     (sc-case tn
+			      ((descriptor-reg any-reg)
+			       (move tn null-tn))
+			      (control-stack
+			       (store-stack-tn tn null-tn)))))
+		 (inst b defaulting-done))))))
+    (load-stack-tn csp-tn sp)))
+
+
+(define-vop (nlx-entry-multiple)
+  (:args (top :target result) (src) (count))
+  ;; Again, no SC restrictions for the args, 'cause the loading would
+  ;; happen before the entry label.
+  (:info label)
+  (:temporary (:scs (any-reg)) dst)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:results (result :scs (any-reg) :from (:argument 0))
+	    (num :scs (any-reg) :from (:argument 0)))
+  (:save-p :force-to-stack)
+  (:vop-var vop)
+  (:generator 30
+    (emit-return-pc label)
+    (note-this-location vop :non-local-entry)
+    (let ((loop (gen-label))
+	  (done (gen-label)))
+
+      ;; Setup results, and test for the zero value case.
+      (load-stack-tn result top)
+      (inst cmpwi count 0)
+      (inst li num 0)
+      (inst beq done)
+
+      ;; Compute dst as one slot down from result, because we inc the index
+      ;; before we use it.
+      (inst subi dst result 4)
+
+      ;; Copy stuff down the stack.
+      (emit-label loop)
+      (inst lwzx temp src num)
+      (inst addi num num (fixnum 1))
+      (inst cmpw num count)
+      (inst stwx temp dst num)
+      (inst bne loop)
+
+      ;; Reset the CSP.
+      (emit-label done)
+      (inst add csp-tn result num))))
+
+
+;;; 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/ppc/parms.lisp b/compiler/ppc/parms.lisp
new file mode 100644
index 000000000..511d8abdb
--- /dev/null
+++ b/compiler/ppc/parms.lisp
@@ -0,0 +1,243 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/parms.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains some parameterizations of various VM
+;;; attributes for the PPC.  This file is separate from other stuff so 
+;;; that it can be compiled and loaded earlier. 
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted to MIPS by William Lott.
+;;;
+
+(in-package "PPC")
+
+
+;;;; Compiler constants.
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+
+(setf (backend-name *target-backend*) "PPC")
+(setf (backend-version *target-backend*) "PowerPC")
+(setf (backend-fasl-file-type *target-backend*) "ppcf")
+(setf (backend-fasl-file-implementation *target-backend*)
+      ppc-fasl-file-implementation)
+(setf (backend-fasl-file-version *target-backend*) 5)
+(setf (backend-register-save-penalty *target-backend*) 3)
+(setf (backend-byte-order *target-backend*) :big-endian)
+(setf (backend-page-size *target-backend*) 4096)
+(setf (c::backend-%features *target-backend*) '(:ppc :linux :new-assembler :new-random :signed-array))
+
+); eval-when
+
+(pushnew :new-assembler *features*)
+
+
+;;;; 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-toplevel :execute :load-toplevel)
+
+(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-divide-by-zero-trap-bit (ash 1 1))
+(defconstant float-underflow-trap-bit (ash 1 2))
+(defconstant float-overflow-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 0))	  ; RD 
+(defconstant float-sticky-bits (byte 10 19))
+(defconstant float-traps-byte (byte 6 3))	  ; 
+(defconstant float-exceptions-byte (byte 5 0))	  ; cexc
+
+(defconstant float-fast-bit 2)		; Non-IEEE mode
+
+); eval-when
+
+;;; NUMBER-STACK-DISPLACEMENT
+;;;
+;;; The number of bytes reserved above the number stack pointer.  These
+;;; slots are required by architecture, mostly (?) to make C backtrace
+;;; work.
+;;; 
+(defconstant number-stack-displacement
+  (* 2 vm:word-bytes))
+
+
+;;;; 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 #x01000000)
+(defparameter target-static-space-start    #x05000000)
+(defparameter target-dynamic-space-start   #x07000000)
+
+
+
+;;;; Other random constants.
+
+(export '(halt-trap pending-interrupt-trap error-trap cerror-trap
+	  breakpoint-trap function-end-breakpoint-trap
+	  after-breakpoint-trap
+	  object-not-list-trap object-not-instance-trap
+	  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
+  after-breakpoint
+  fixnum-additive-overflow)
+
+(defenum (:prefix object-not- :suffix -trap :start 16)
+  list
+  instance)
+
+(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*
+
+    ;; 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*
+
+    #|kernel::*current-thread*|#
+    ))
+
+(defparameter static-functions
+  '(length
+    two-arg-+ two-arg-- two-arg-* 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
+    ))
+
+
+
+;;;; Assembler parameters:
+
+;;; The number of bits per element in the assemblers code vector.
+;;;
+(defparameter *assembly-unit-length* 8)
diff --git a/compiler/ppc/pred.lisp b/compiler/ppc/pred.lisp
new file mode 100644
index 000000000..840a71738
--- /dev/null
+++ b/compiler/ppc/pred.lisp
@@ -0,0 +1,44 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice 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 Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/pred.lisp,v 1.1 2001/02/11 14:22:05 dtc Rel $
+;;;
+;;;    This file contains the VM definition of predicate VOPs for the SPARC.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by William Lott.
+;;; 
+
+(in-package "PPC")
+
+
+;;;; 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)))
+
+
+;;;; 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 cmpw x y)
+    (inst b? (if not-p :ne :eq) target)))
diff --git a/compiler/ppc/print.lisp b/compiler/ppc/print.lisp
new file mode 100644
index 000000000..74550a259
--- /dev/null
+++ b/compiler/ppc/print.lisp
@@ -0,0 +1,42 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice 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 Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/print.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $
+;;;
+;;; This file contains VOPs for things like printing during %initial-function
+;;; before the world is initialized.
+;;;
+;;; Written by William Lott.
+
+(in-package "PPC")
+
+
+(define-vop (print)
+  (:args (object :scs (descriptor-reg any-reg) :target nl0))
+  (:results (result :scs (descriptor-reg)))
+  (:save-p t)
+  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) nl0)
+  (:temporary (:sc any-reg :offset cfunc-offset) cfunc)
+  (:temporary (:sc interior-reg :offset lip-offset) lip)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:vop-var vop)
+  (:generator 100
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (move nl0 object)
+      (inst lr temp  (make-fixup "call_into_c" :foreign))
+      (inst mr lip temp)
+      (inst mtctr lip)
+      (inst lr cfunc (make-fixup "debug_print" :foreign))
+      (inst bctrl)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save))
+      (move result nl0))))
diff --git a/compiler/ppc/sap.lisp b/compiler/ppc/sap.lisp
new file mode 100644
index 000000000..8b21fcfe8
--- /dev/null
+++ b/compiler/ppc/sap.lisp
@@ -0,0 +1,290 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/sap.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the PPC VM definition of SAP operations.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "PPC")
+
+
+;;;; 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 "pointer to SAP coercion")
+  (: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 (sap :scs (sap-reg) :to :save))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:results (res :scs (descriptor-reg)))
+  (:note "SAP to pointer coercion") 
+  (:generator 20
+    (with-fixed-allocation (res pa-flag ndescr sap-type sap-size)
+      (storew sap res 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))))
+  (:note "SAP move")
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+;;;
+(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))
+  (:note "SAP argument move")
+  (:generator 0
+    (sc-case y
+      (sap-reg
+       (move y x))
+      (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 int sap)))
+
+(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 sap int)))
+
+
+
+;;;; POINTER+ and POINTER-
+
+(define-vop (pointer+)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg))
+	 (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 2
+    (inst add res ptr offset)))
+
+(define-vop (pointer+-c)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg)))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 16)))
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (inst addi res ptr offset)))
+
+(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 res ptr1 ptr2)))
+
+
+
+;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
+
+(eval-when (:compile-toplevel :execute)
+
+(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 (sap :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 'lbzx)
+		    (:short (if signed 'lhax 'lhzx))
+		    (:long 'lwzx)
+		    (:single 'lfsx)
+		    (:double 'lfdx))
+		 result sap offset)
+           ,@(when (and (eq size :byte) signed)
+               '((inst extsb result result)))))
+       (define-vop (,ref-name-c)
+	 (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg)))
+	 (:arg-types system-area-pointer (:constant (signed-byte 16)))
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	   (inst ,(ecase size
+		    (:byte 'lbz)
+		    (:short (if signed 'lha 'lhz))
+		    (:long 'lwz)
+		    (:single 'lfs)
+		    (:double 'lfd))
+		 result sap offset)
+           ,@(when (and (eq size :byte) signed)
+               '((inst extsb result result)))))
+       (define-vop (,set-name)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg))
+		(offset :scs (unsigned-reg))
+		(value :scs (,sc) :target result))
+	 (:arg-types system-area-pointer unsigned-num ,type)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	   (inst ,(ecase size
+		    (:byte 'stbx)
+		    (:short 'sthx)
+		    (:long 'stwx)
+		    (:single 'stfsx)
+		    (:double 'stfdx))
+		 value sap offset)
+	   (unless (location= result value)
+	     ,@(case size
+		 (:single
+		  '((inst frsp result value)))
+		 (:double
+		  '((inst fmr result value)))
+		 (t
+		  '((inst mr result value)))))))
+       (define-vop (,set-name-c)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg))
+		(value :scs (,sc) :target result))
+	 (:arg-types system-area-pointer (:constant (signed-byte 16)) ,type)
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	   (inst ,(ecase size
+		    (:byte 'stb)
+		    (:short 'sth)
+		    (:long 'stw)
+		    (:single 'stfs)
+		    (:double 'stfd))
+		 value sap offset)
+	   (unless (location= result value)
+	     ,@(case size
+		 (:single
+		  '((inst frsp result value)))
+		 (:double
+		  '((inst fmr result value)))
+		 (t
+		  '((inst mr result value))))))))))
+
+); eval-when (:compile-toplevel :execute)
+
+(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 :single)
+(def-system-ref-and-set sap-ref-double %set-sap-ref-double
+  double-reg double-float :double)
+
+
+
+;;; 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 sap vector
+	  (- (* vector-data-offset word-bytes) other-pointer-type))))
+
diff --git a/compiler/ppc/static-fn.lisp b/compiler/ppc/static-fn.lisp
new file mode 100644
index 000000000..ca0841d4b
--- /dev/null
+++ b/compiler/ppc/static-fn.lisp
@@ -0,0 +1,150 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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 (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/static-fn.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $
+;;;
+;;; This file contains the VOPs and macro magic necessary to call static
+;;; functions.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "PPC")
+
+
+
+(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 (descriptor-reg)) func)
+  (: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-toplevel :load-toplevel :execute)
+
+
+(defun static-function-template-name (num-args num-results)
+  (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
+		  num-args num-results)))
+
+
+(defun moves (dst src)
+  (collect ((moves))
+    (do ((dst dst (cdr dst))
+	 (src src (cdr src)))
+	((or (null dst) (null src)))
+      (moves `(move ,(car dst) ,(car src))))
+    (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 (temp-names) (arg-names))
+	     (inst lwz func null-tn (static-function-offset symbol))
+	     (inst lr nargs (fixnum ,num-args))
+	     (when cur-nfp
+	       (store-stack-tn nfp-save cur-nfp))
+	     (inst mr old-fp cfp-tn)
+	     (inst mr cfp-tn csp-tn)
+	     (inst compute-lra-from-code lra code-tn lra-label temp)
+	     (note-this-location vop :call-site)
+	     (inst mr code-tn func)
+	     (inst mtctr func)
+	     (inst bctr)
+	     (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 (result-names) (temp-names))))))))
+
+
+) ; eval-when (:compile-toplevel :load-toplevel :execute)
+
+
+(macrolet ((frob (num-args num-res)
+	     (static-function-template-vop (eval num-args) (eval num-res))))
+  (frob 0 1)
+  (frob 1 1)
+  (frob 2 1)
+  (frob 3 1)
+  (frob 4 1)
+  #|(frob 5 1)|#)
+
+
+(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/ppc/subprim.lisp b/compiler/ppc/subprim.lisp
new file mode 100644
index 000000000..1fa27b910
--- /dev/null
+++ b/compiler/ppc/subprim.lisp
@@ -0,0 +1,61 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/subprim.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    Linkage information for standard static functions, and random vops.
+;;;
+;;; Written by William Lott.
+;;; 
+(in-package "PPC")
+
+
+
+;;;; 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)) 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
+    (let ((done (gen-label))
+	  (loop (gen-label))
+	  (not-list (generate-cerror-code vop object-not-list-error object)))
+      (move ptr object)
+      (move count zero-tn)
+
+      (emit-label loop)
+
+      (inst cmpw ptr null-tn)
+      (inst beq done)
+
+      (test-type ptr temp not-list t vm:list-pointer-type)
+
+      (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type)
+      (inst addi count count (fixnum 1))
+      (test-type ptr temp loop nil vm:list-pointer-type)
+
+      (cerror-call vop done object-not-list-error ptr)
+
+      (emit-label done)
+      (move result count))))
+       
+
+(define-static-function length (object) :translate length)
+
diff --git a/compiler/ppc/system.lisp b/compiler/ppc/system.lisp
new file mode 100644
index 000000000..e2c8f216d
--- /dev/null
+++ b/compiler/ppc/system.lisp
@@ -0,0 +1,249 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/system.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    PPC VM definitions of various system hacking operations.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Mips conversion by William Lott and Christopher Hoover.
+;;;
+(in-package "PPC")
+
+
+
+;;;; Type frobbing VOPs
+
+(define-vop (get-lowtag)
+  (:translate get-lowtag)
+  (:policy :fast-safe)
+  (:args (object :scs (any-reg descriptor-reg)))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+    (inst andi. result object vm:lowtag-mask)))
+
+(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
+    ;; Grab the lowtag.
+    (inst andi. result object lowtag-mask)
+    ;; Check for various pointer types.
+    (inst cmpwi result list-pointer-type)
+    (inst beq done)
+    (inst cmpwi result other-pointer-type)
+    (inst beq other-pointer)
+    (inst cmpwi result function-pointer-type)
+    (inst beq function-pointer)
+    (inst cmpwi result instance-pointer-type)
+    (inst beq done)
+    ;; Okay, it is an immediate.  If fixnum, we want zero.  Otherwise,
+    ;; we want the low 8 bits.
+    (inst andi. result object #b11)
+    (inst beq done)
+    ;; It wasn't a fixnum, so get the low 8 bits.
+    (inst andi. result object type-mask)
+    (inst b done)
+    
+    FUNCTION-POINTER
+    (load-type result object (- function-pointer-type))
+    (inst b done)
+
+    OTHER-POINTER
+    (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 (- vm: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 function (- 3 function-pointer-type))
+    (move result type)))
+
+(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 vm:other-pointer-type)
+    (inst srwi res res vm:type-bits)))
+
+(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 vm:function-pointer-type)
+    (inst srwi res res vm:type-bits)))
+
+(define-vop (set-header-data)
+  (:translate set-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg) :target res)
+	 (data :scs (any-reg immediate zero)))
+  (:arg-types * positive-fixnum)
+  (:results (res :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) t1 t2)
+  (:generator 6
+    (loadw t1 x 0 vm:other-pointer-type)
+    (inst andi. t1 t1 vm:type-mask)
+    (sc-case data
+      (any-reg
+       (inst slwi t2 data (- vm:type-bits 2))
+       (inst or t1 t1 t2))
+      (immediate
+       (inst ori t1 t1 (ash (tn-value data) vm:type-bits)))
+      (zero))
+    (storew t1 x 0 vm:other-pointer-type)
+    (move res x)))
+
+
+(define-vop (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 slwi res ptr 3)
+    (inst srwi res res 1)))
+
+(define-vop (make-other-immediate-type)
+  (:args (val :scs (any-reg descriptor-reg))
+	 (type :scs (any-reg descriptor-reg immediate)
+	       :target temp))
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 2
+    (sc-case type
+      (immediate
+       (inst slwi temp val vm:type-bits)
+       (inst ori res temp (tn-value type)))
+      (t
+       (inst srawi temp type 2)
+       (inst slwi res val (- vm:type-bits 2))
+       (inst or res res temp)))))
+
+
+;;;; 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 int alloc-tn)))
+
+(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 int bsp-tn)))
+
+(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 int csp-tn)))
+
+
+;;;; 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 vm:other-pointer-type)
+    (inst srwi ndescr ndescr vm:type-bits)
+    (inst slwi ndescr ndescr vm:word-shift)
+    (inst subi ndescr ndescr vm:other-pointer-type)
+    (inst add sap code ndescr)))
+
+(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 srwi ndescr ndescr vm:type-bits)
+    (inst slwi ndescr ndescr vm:word-shift)
+    (inst add ndescr ndescr offset)
+    (inst addi ndescr ndescr (- vm:function-pointer-type vm:other-pointer-type))
+    (inst add func code ndescr)))
+
+
+
+;;;; 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 unimp pending-interrupt-trap)))
+
+
+(define-vop (halt)
+  (:generator 1
+    (inst unimp 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)))
+      (assert (typep offset '(signed-byte 16)))
+      (inst lwz count count-vector offset)
+      (inst addi count count 1)
+      (inst stw count count-vector offset))))
diff --git a/compiler/ppc/type-vops.lisp b/compiler/ppc/type-vops.lisp
new file mode 100644
index 000000000..c2ebe168f
--- /dev/null
+++ b/compiler/ppc/type-vops.lisp
@@ -0,0 +1,451 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/type-vops.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;; 
+;;; This file contains the VM definition of type testing and checking VOPs
+;;; for the PPC
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "PPC")
+
+
+;;;; Simple type checking and testing:
+;;;
+;;;    These types are represented by a single type code, so are easily
+;;; open-coded as a mask and compare.
+
+(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)) temp)
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(define-vop (type-predicate)
+  (:args (value :scs (any-reg descriptor-reg)))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:temporary (:scs (non-descriptor-reg)) temp))
+
+(eval-when (:compile-toplevel :execute)
+
+(defun cost-to-test-types (type-codes)
+  (+ (* 2 (length type-codes))
+     (if (> (apply #'max type-codes) vm: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 result value))))))
+       ,@(when ptype
+	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+); eval-when (:compile-toplevel :execute)
+
+(def-type-vops fixnump nil nil object-not-fixnum-error
+  vm:even-fixnum-type vm:odd-fixnum-type)
+(define-vop (check-fixnum check-type)
+  (:generator 3
+    (inst andi. temp value 3)
+    (inst twi 0 value (error-number-or-lose 'object-not-fixnum-error))
+    (inst twi :ne temp 0)
+    (move result value)))
+(primitive-type-vop check-fixnum (:check) fixnum)
+
+(def-type-vops functionp nil nil
+  object-not-function-error vm:function-pointer-type)
+(define-vop (check-function check-type)
+  (:generator 3
+    (inst andi. temp value 7)
+    (inst twi 0 value (error-number-or-lose 'object-not-function-error))
+    (inst twi :ne temp vm:function-pointer-type)
+    (move result value)))
+(primitive-type-vop check-function (:check) function)
+
+(def-type-vops listp nil nil
+  object-not-list-error vm:list-pointer-type)
+(define-vop (check-list check-type)
+  (:generator 3
+    (inst andi. temp value 7)
+    (inst twi 0 value (error-number-or-lose 'object-not-list-error))
+    (inst twi :ne temp vm:list-pointer-type)
+    (move result value)))
+(primitive-type-vop check-list (:check) list)
+
+(def-type-vops %instancep nil nil
+  object-not-instance-error vm:instance-pointer-type)
+(define-vop (check-instance check-type)
+  (:generator 3
+    (inst andi. temp value 7)
+    (inst twi 0 value (error-number-or-lose 'object-not-instance-error))
+    (inst twi :ne temp vm:instance-pointer-type)
+    (move result value)))
+(primitive-type-vop check-instance (:check) instance)
+
+
+(def-type-vops bignump check-bignum bignum
+  object-not-bignum-error vm:bignum-type)
+
+(def-type-vops ratiop check-ratio ratio
+  object-not-ratio-error vm:ratio-type)
+
+(def-type-vops complexp check-complex complex
+  object-not-complex-error vm:complex-type)
+
+(def-type-vops single-float-p check-single-float single-float
+  object-not-single-float-error vm:single-float-type)
+
+(def-type-vops double-float-p check-double-float double-float
+  object-not-double-float-error vm:double-float-type)
+
+(def-type-vops simple-string-p check-simple-string simple-string
+  object-not-simple-string-error vm:simple-string-type)
+
+(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+  object-not-simple-bit-vector-error vm:simple-bit-vector-type)
+
+(def-type-vops simple-vector-p check-simple-vector simple-vector
+  object-not-simple-vector-error vm: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
+  vm: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
+  vm: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
+  vm: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
+  vm: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
+  vm:simple-array-unsigned-byte-32-type)
+
+#+signed-array
+(def-type-vops simple-array-signed-byte-8-p
+  check-simple-array-signed-byte-8
+  simple-array-signed-byte-8
+  object-not-simple-array-signed-byte-8-error
+  simple-array-signed-byte-8-type)
+
+#+signed-array
+(def-type-vops simple-array-signed-byte-16-p
+  check-simple-array-signed-byte-16
+  simple-array-signed-byte-16
+  object-not-simple-array-signed-byte-16-error
+  simple-array-signed-byte-16-type)
+
+#+signed-array
+(def-type-vops simple-array-signed-byte-30-p
+  check-simple-array-signed-byte-30
+  simple-array-signed-byte-30
+  object-not-simple-array-signed-byte-30-error
+  simple-array-signed-byte-30-type)
+
+#+signed-array
+(def-type-vops simple-array-signed-byte-32-p
+  check-simple-array-signed-byte-32
+  simple-array-signed-byte-32
+  object-not-simple-array-signed-byte-32-error
+  simple-array-signed-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
+  vm: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
+  vm:simple-array-double-float-type)
+
+(def-type-vops base-char-p check-base-char base-char
+  object-not-base-char-error vm:base-char-type)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+  system-area-pointer object-not-sap-error vm:sap-type)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+  object-not-weak-pointer-error vm:weak-pointer-type)
+
+(def-type-vops scavenger-hook-p nil nil nil
+  0)
+
+(def-type-vops code-component-p nil nil nil
+  vm:code-header-type)
+
+(def-type-vops lra-p nil nil nil
+  vm:return-pc-header-type)
+
+(def-type-vops fdefn-p nil nil nil
+  vm:fdefn-type)
+
+(def-type-vops funcallable-instance-p nil nil nil
+  vm:funcallable-instance-header-type)
+
+(def-type-vops array-header-p nil nil nil
+  vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type
+  vm:complex-vector-type vm:complex-array-type)
+
+(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error
+  vm:function-pointer-type vm:symbol-header-type)
+
+(def-type-vops stringp check-string nil object-not-string-error
+  vm:simple-string-type vm:complex-string-type)
+
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+  vm:simple-bit-vector-type vm:complex-bit-vector-type)
+
+(def-type-vops vectorp check-vector nil object-not-vector-error
+  vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type
+  vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type
+  vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type
+  vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type
+  vm:simple-array-double-float-type vm:complex-string-type
+  vm:complex-bit-vector-type vm:complex-vector-type)
+
+(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
+  vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
+  vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
+  vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
+  vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
+  vm:simple-array-single-float-type vm:simple-array-double-float-type)
+
+(def-type-vops arrayp check-array nil object-not-array-error
+  vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
+  vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
+  vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
+  vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
+  vm:simple-array-single-float-type vm:simple-array-double-float-type
+  vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type
+  vm:complex-array-type)
+
+(def-type-vops numberp check-number nil object-not-number-error
+  vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type
+  vm:single-float-type vm:double-float-type vm:complex-type)
+
+(def-type-vops rationalp check-rational nil object-not-rational-error
+  vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+  vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)
+
+(def-type-vops floatp check-float nil object-not-float-error
+  vm:single-float-type vm:double-float-type)
+
+(def-type-vops realp check-real nil object-not-real-error
+  vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type
+  vm:single-float-type vm:double-float-type)
+
+
+;;;; Other integer ranges.
+
+;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+
+(define-vop (signed-byte-32-p type-predicate)
+  (:translate signed-byte-32-p)
+  (:generator 45
+    (let ((not-target (gen-label)))
+      (multiple-value-bind
+	  (yep nope)
+	  (if not-p
+	      (values not-target target)
+	      (values target not-target))
+	(inst andi. temp value #x3)
+	(inst beq yep)
+	(test-type value temp nope t vm:other-pointer-type)
+	(loadw temp value 0 vm:other-pointer-type)
+	(inst cmpwi temp (+ (ash 1 vm:type-bits)
+			  vm:bignum-type))
+	(inst b? (if not-p :ne :eq) target)
+	(emit-label not-target)))))
+
+(define-vop (check-signed-byte-32 check-type)
+  (:generator 45
+    (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
+	  (yep (gen-label)))
+      (inst andi. temp value #x3)
+      (inst beq yep)
+      (test-type value temp nope t vm:other-pointer-type)
+      (loadw temp value 0 vm:other-pointer-type)
+      (inst cmpwi temp (+ (ash 1 vm:type-bits) vm:bignum-type))
+      (inst bne nope)
+      (emit-label yep)
+      (move result value))))
+
+
+;;; 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.
+
+(define-vop (unsigned-byte-32-p type-predicate)
+  (:translate unsigned-byte-32-p)
+  (:generator 45
+    (let ((not-target (gen-label))
+	  (single-word (gen-label))
+ 	  (fixnum (gen-label)))
+      (multiple-value-bind
+	  (yep nope)
+	  (if not-p
+	      (values not-target target)
+	      (values target not-target))
+	;; Is it a fixnum?
+	(inst andi. temp value #x3)
+        (inst cmpwi :cr1 value 0)
+        (inst beq fixnum)
+
+	;; If not, is it an other pointer?
+	(test-type value temp nope t vm:other-pointer-type)
+	;; Get the header.
+	(loadw temp value 0 vm:other-pointer-type)
+	;; Is it one?
+	(inst cmpwi temp (+ (ash 1 vm:type-bits) vm:bignum-type))
+	(inst beq single-word)
+	;; If it's other than two, we can't be an (unsigned-byte 32)
+	(inst cmpwi temp (+ (ash 2 vm:type-bits) vm:bignum-type))
+	(inst bne nope)
+	;; Get the second digit.
+	(loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
+	;; All zeros, its an (unsigned-byte 32).
+	(inst cmpwi temp 0)
+	(inst beq yep)
+	;; Otherwise, it isn't.
+	(inst b nope)
+	
+	(emit-label single-word)
+	;; Get the single digit.
+	(loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
+	(inst cmpwi :cr1 temp 0)
+
+	;; positive implies (unsigned-byte 32).
+	(emit-label fixnum)
+	(inst b?  :cr1 (if not-p :lt :ge) target)
+
+	(emit-label not-target)))))	  
+
+(define-vop (check-unsigned-byte-32 check-type)
+  (:generator 45
+    (let ((nope
+	   (generate-error-code vop object-not-unsigned-byte-32-error value))
+	  (yep (gen-label))
+	  (fixnum (gen-label))
+	  (single-word (gen-label)))
+      ;; Is it a fixnum?
+      (inst andi. temp value #x3)
+      (inst cmpwi :cr1 value 0)
+      (inst beq fixnum)
+
+      ;; If not, is it an other pointer?
+      (test-type value temp nope t vm:other-pointer-type)
+      ;; Get the number of digits.
+      (loadw temp value 0 vm:other-pointer-type)
+      ;; Is it one?
+      (inst cmpwi temp (+ (ash 1 vm:type-bits) vm:bignum-type))
+      (inst beq single-word)
+      ;; If it's other than two, we can't be an (unsigned-byte 32)
+      (inst cmpwi temp (+ (ash 2 vm:type-bits) vm:bignum-type))
+      (inst bne nope)
+      ;; Get the second digit.
+      (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
+      ;; All zeros, its an (unsigned-byte 32).
+      (inst cmpwi temp 0)
+      (inst beq yep)
+      ;; Otherwise, it isn't.
+      (inst b nope)
+      
+      (emit-label single-word)
+      ;; Get the single digit.
+      (loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
+      ;; positive implies (unsigned-byte 32).
+      (inst cmpwi :cr1 temp 0)
+      
+      (emit-label fixnum)
+      (inst blt :cr1 nope)
+      
+      (emit-label yep)
+      (move result value))))
+
+
+
+
+;;;; List/symbol types:
+;;; 
+;;; symbolp (or symbol (eq nil))
+;;; consp (and list (not (eq nil)))
+
+(define-vop (symbolp type-predicate)
+  (:translate symbolp)
+  (:generator 12
+    (let* ((drop-thru (gen-label))
+	   (is-symbol-label (if not-p drop-thru target)))
+      (inst cmpw value null-tn)
+      (inst beq is-symbol-label)
+      (test-type value temp target not-p vm:symbol-header-type)
+      (emit-label drop-thru))))
+
+(define-vop (check-symbol check-type)
+  (:generator 12
+    (let ((drop-thru (gen-label))
+	  (error (generate-error-code vop object-not-symbol-error value)))
+      (inst cmpw value null-tn)
+      (inst beq drop-thru)
+      (test-type value temp error t vm:symbol-header-type)
+      (emit-label drop-thru)
+      (move result value))))
+  
+(define-vop (consp type-predicate)
+  (:translate consp)
+  (:generator 8
+    (let* ((drop-thru (gen-label))
+	   (is-not-cons-label (if not-p target drop-thru)))
+      (inst cmpw value null-tn)
+      (inst beq is-not-cons-label)
+      (test-type value temp target not-p vm:list-pointer-type)
+      (emit-label drop-thru))))
+
+(define-vop (check-cons check-type)
+  (:generator 8
+    (let ((error (generate-error-code vop object-not-cons-error value)))
+      (inst cmpw value null-tn)
+      (inst beq error)
+      (test-type value temp error t vm:list-pointer-type)
+      (move result value))))
+
diff --git a/compiler/ppc/values.lisp b/compiler/ppc/values.lisp
new file mode 100644
index 000000000..6da1aeea5
--- /dev/null
+++ b/compiler/ppc/values.lisp
@@ -0,0 +1,127 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/values.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the implementation of unknown-values VOPs.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted for SPARC by William Lott.
+;;; 
+
+(in-package "PPC")
+
+(define-vop (reset-stack-pointer)
+  (:args (ptr :scs (any-reg)))
+  (:generator 1
+    (move csp-tn ptr)))
+
+
+;;; 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
+    (inst mr start csp-tn)
+    (inst addi csp-tn csp-tn (* nvals vm:word-bytes))
+    (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 lr count (fixnum nvals))))
+
+;;; 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)) ndescr)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 0
+    (let ((loop (gen-label))
+	  (done (gen-label)))
+
+      (move list arg)
+      (move start csp-tn)
+
+      (emit-label loop)
+      (inst cmpw list null-tn)
+      (loadw temp list vm:cons-car-slot vm:list-pointer-type)
+      (inst beq done)
+      (loadw list list vm:cons-cdr-slot vm:list-pointer-type)
+      (inst addi csp-tn csp-tn vm:word-bytes)
+      (storew temp csp-tn -1)
+      (test-type list ndescr loop nil vm:list-pointer-type)
+      (error-call vop bogus-argument-to-values-list-error list)
+
+      (emit-label done)
+      (inst sub count csp-tn start))))
+
+
+;;; Copy the more arg block to the top of the stack so we can use them
+;;; as function arguments.
+;;;
+(define-vop (%more-arg-values)
+  (:args (context :scs (descriptor-reg any-reg) :target src)
+	 (skip :scs (any-reg zero immediate))
+	 (num :scs (any-reg) :target count))
+  (:arg-types * positive-fixnum positive-fixnum)
+  (:temporary (:sc any-reg :from (:argument 0)) src)
+  (:temporary (:sc any-reg :from (:argument 2)) dst)
+  (:temporary (:sc descriptor-reg :from (:argument 1)) temp)
+  (:temporary (:sc any-reg) i)
+  (:results (start :scs (any-reg))
+	    (count :scs (any-reg)))
+  (:generator 20
+    (sc-case skip
+      (zero
+       (inst mr src context))
+      (immediate
+       (inst addi src context (* (tn-value skip) word-bytes)))
+      (any-reg
+       (inst add src context skip)))
+    (inst mr. count num)
+    (inst mr start csp-tn)
+    (inst beq done)
+    (inst mr dst csp-tn)
+    (inst add csp-tn csp-tn count)
+    (inst mr i count)
+    LOOP
+    (inst cmpwi i 4)
+    (inst subi i i 4)
+    (inst lwzx temp src i)
+    (inst stwx temp dst i)
+    (inst bne loop)
+    DONE))
diff --git a/compiler/ppc/vm.lisp b/compiler/ppc/vm.lisp
new file mode 100644
index 000000000..276050ba1
--- /dev/null
+++ b/compiler/ppc/vm.lisp
@@ -0,0 +1,334 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; 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/ppc/vm.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition for the POWERMAC.
+;;;
+(in-package "PPC")
+
+
+;;;; Define the registers
+
+(eval-when (:compile-toplevel :execute)
+
+(defmacro defreg (name offset)
+  (let ((offset-sym (symbolicate name "-OFFSET")))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (defconstant ,offset-sym ,offset)
+       (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
+
+(defmacro defregset (name &rest regs)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (defconstant ,name
+       (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
+
+); eval-when (:compile-toplevel :execute)
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defvar *register-names* (make-array 32 :initial-element nil))
+
+); eval-when (:compile-toplevel :load-toplevel :execute)
+
+
+
+(defreg zero 0)
+(defreg nsp 1)
+(defreg rtoc 2)                         ; May be "NULL" someday.
+(defreg nl0 3)
+(defreg nl1 4)
+(defreg nl2 5)
+(defreg nl3 6)
+(defreg nl4 7)
+(defreg nl5 8)
+(defreg nl6 9)
+(defreg nl7 10)
+(defreg nargs 11)
+(defreg nfp 12)
+(defreg cfunc 13)
+(defreg bsp 14)
+(defreg cfp 15)
+(defreg csp 16)
+(defreg alloc 17)
+(defreg null 18)
+(defreg code 19)
+(defreg cname 20)
+(defreg lexenv 21)
+(defreg ocfp 22)
+(defreg lra 23)
+(defreg a0 24)
+(defreg a1 25)
+(defreg a2 26)
+(defreg a3 27)
+(defreg l0 28)
+(defreg l1 29)
+(defreg l2 30)
+(defreg lip 31)
+
+(defregset non-descriptor-regs
+  nl0 nl1 nl2 nl3 nl4 nl5 nl6 nl7 cfunc nargs nfp)
+
+(defregset descriptor-regs
+  a0 a1 a2 a3  ocfp lra cname lexenv l0 l1 l2 )
+
+(defregset register-arg-offsets
+  a0 a1 a2 a3)
+
+
+
+;;;; SB and SC definition:
+
+(define-storage-base registers :finite :size 32)
+(define-storage-base float-registers :finite :size 32)
+(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)
+
+  ;; 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 a 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 (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31)
+   ;; ### Note: We really should have every location listed, but then we
+   ;; would have to make load-tns work with element-sizes other than 1.
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (single-stack))
+
+  ;; Non-Descriptor double-floats.
+  (double-reg float-registers
+   :locations (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31)
+   ;; ### Note: load-tns don't work with an element-size other than 1.
+   ;; :element-size 2 :alignment 2
+   :constant-scs ()
+   :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-toplevel :execute)
+
+(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-toplevel :execute)
+
+(defregtn zero any-reg)
+(defregtn lip interior-reg)
+(defregtn null descriptor-reg)
+(defregtn code descriptor-reg)
+(defregtn alloc any-reg)
+
+(defregtn nargs any-reg)
+(defregtn bsp any-reg)
+(defregtn csp any-reg)
+(defregtn cfp any-reg)
+(defregtn ocfp any-reg)
+(defregtn nsp any-reg)
+
+
+
+;;; 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))))
+
+
+;;;; 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-toplevel :load-toplevel :execute)
+
+;;; 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 4)
+
+;;; Names to use for the argument registers.
+;;; 
+(defconstant register-arg-names '(a0 a1 a2 a3))
+
+); Eval-When (:compile-toplevel :load-toplevel :execute)
+
+
+;;; 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))
+
+(export 'single-value-return-byte-offset)
+
+;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
+;;;
+;;; This is used by the debugger.
+;;;
+(defconstant single-value-return-byte-offset 8)
+
+
+;;; 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"))))
diff --git a/tools/setup.lisp b/tools/setup.lisp
index cb7bd147a..85e030c57 100644
--- a/tools/setup.lisp
+++ b/tools/setup.lisp
@@ -3,7 +3,7 @@
 ;;; **********************************************************************
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/setup.lisp,v 1.29 1999/01/09 11:05:20 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/setup.lisp,v 1.30 2001/02/11 14:22:07 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -220,6 +220,7 @@
 	  ((c:target-featurep :x86) "x86/")
 	  ((c:target-featurep :alpha) "alpha/")
 	  ((c:target-featurep :sgi) "mips/")
+	  ((c:target-featurep :ppc) "ppc/")
 	  (t
 	   (error "What machine is this?")))
     (make-pathname :directory (pathname-directory f)))))
diff --git a/tools/worldbuild.lisp b/tools/worldbuild.lisp
index 2d262910c..66b81d057 100644
--- a/tools/worldbuild.lisp
+++ b/tools/worldbuild.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.41 1998/05/01 01:21:42 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.42 2001/02/11 14:22:07 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -55,6 +55,13 @@
 	  "target:assembly/mips/array.assem"
 	  "target:assembly/mips/arith.assem"
 	  "target:assembly/mips/alloc.assem"))
+    ,@(when (c:backend-featurep :ppc)
+	'("target:assembly/ppc/assem-rtns.assem"
+	  "target:assembly/ppc/array.assem"
+	  "target:assembly/ppc/arith.assem"
+	  "target:assembly/ppc/alloc.assem"))
+    
+    
 
     "target:code/type-boot"
     "target:code/fdefinition"
@@ -155,6 +162,8 @@
 	'("target:code/alpha-vm"))
     ,@(when (c:backend-featurep :sgi)
 	'("target:code/sgi-vm"))
+    ,@(when (c:backend-featurep :ppc)
+	'("target:code/ppc-vm"))
 
     "target:code/signal"
     "target:code/interr"
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
index 7bb71e23e..849ce2dcd 100644
--- a/tools/worldcom.lisp
+++ b/tools/worldcom.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.79 2000/08/12 07:32:50 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.80 2001/02/11 14:22:08 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -92,6 +92,13 @@
   (comf "target:assembly/mips/arith" :assem t)
   (comf "target:assembly/mips/alloc" :assem t))
 
+(when (c:backend-featurep :ppc)
+  (comf "target:assembly/ppc/assem-rtns" :assem t)
+  (comf "target:assembly/ppc/array" :assem t)
+  (comf "target:assembly/ppc/arith" :assem t)
+  (comf "target:assembly/ppc/alloc" :assem t))
+
+
 ;;; these guys can supposedly come in any order, but not really.
 ;;; some are put at the end so macros don't run interpreted and stuff.
 
@@ -176,6 +183,8 @@
   (comf "target:code/alpha-vm"))
 (when (c:backend-featurep :sgi)
   (comf "target:code/sgi-vm"))
+(when (c:backend-featurep :ppc)
+  (comf "target:code/ppc-vm"))
 
 (comf "target:code/symbol")
 (comf "target:code/bignum")
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
index 24536d9ab..b2f817efd 100644
--- a/tools/worldload.lisp
+++ b/tools/worldload.lisp
@@ -6,7 +6,7 @@
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.88 1998/01/16 07:22:25 dtc Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.89 2001/02/11 14:22:08 dtc Exp $
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -63,6 +63,7 @@
 	#+hppa "c:hppa/"
 	#+x86 "c:x86/"
 	#+alpha "c:alpha/"
+	#+ppc "c:ppc/"
 	"c:generic/"))
 (setf (ext:search-list "assem:")
       '(#+(or pmax sgi) "target:assembly/mips/"
@@ -71,6 +72,7 @@
 	#+hppa "target:assembly/hppa/"
 	#+x86 "target:assembly/x86/"
 	#+alpha "target:assembly/alpha/"
+	#+ppc "target:assembly/ppc/"
 	"target:assembly/"))
 (setf (ext:search-list "hem:") '("target:hemlock/"))
 (setf (ext:search-list "clx:") '("target:clx/"))
-- 
GitLab