diff --git a/compiler/rt/insts.lisp b/compiler/rt/insts.lisp
index be354166455cdca2d31c538ada81543b6c81ff1d..9e74c09127e0799742286c6be603ea0b910ab42f 100644
--- a/compiler/rt/insts.lisp
+++ b/compiler/rt/insts.lisp
@@ -2,9 +2,13 @@
 ;;;
 ;;; **********************************************************************
 ;;; 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)
+;;; 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/rt/insts.lisp,v 1.8 1991/07/23 12:14:00 ram Exp $")
+;;;
 ;;; **********************************************************************
 ;;;
 ;;; Description of the IBM RT instruction set.
@@ -1079,3 +1083,313 @@
   (inst mc68881-store-status-inst data temp
 	(do-68881-inst :move temp :creg creg :data data
 		       :class :scr-to-mem)))
+
+;;; AFPA instruction set details:
+
+;;; Support for the AFPA on IBM RT PC (APC and EAPC models).
+
+(defconstant afpa-opcodes
+  '((:absl . #x74)
+    (:abss . #x75)
+    (:addl . #x40)
+    (:adds . #x41)
+    (:coml . #x48)
+    (:coms . #x49)
+    (:comtl . #x4A)
+    (:comts . #x4B)
+    (:csl  . #x1B)
+    (:cls  . #x16)
+    (:cwl  . #x03)
+    (:cws  . #x07)
+    (:copl . #x44)
+    (:cops . #x45)
+    (:divl . #x60)
+    (:divs . #x61)
+    (:flw  . #x3B)
+    (:fsw  . #x3F)
+    (:mull . #x70)
+    (:muls . #x71)
+    (:negl . #x54)
+    (:negs . #x55)
+    (:noop . #x9F)
+    (:rdfr . #xBC) ; type = ld
+    (:rlw  . #x23)
+    (:rsw  . #x27)
+    (:subl . #x50)
+    (:subs . #x51)
+    (:tlw  . #x2B)
+    (:tsw  . #x2F)
+    (:wtfr . #x94)))
+  
+(defconstant afpa-special-opcodes
+  '((:wtstr . #.(ash #x10FEE 2)) ; DS = #b01, OP1, OP2 = #xE.
+    (:rdstr . #.(ash #x137EE 2)) ; DS = #b01, OP1, OP2 = #xE, type = ld
+    (:rddma . #.(ash #xF9F00 2)))) ; DS = #b11, OP2 = #x30
+
+(defconstant afpa-ds-codes
+  '((:register . #b00)
+    (:fr1-immediate . #b10)
+    (:fr2-immediate . #b01)))
+
+(defconstant afpa-ts-codes
+  '((:pio . #b00)
+    (:word . #b01)
+    (:single . #b01)
+    (:double . #b10)
+    (:multiple . #b11)))
+
+#|
+(defconstant afpa-atanl #x0D4)
+(defconstant afpa-cosl #x0C2)
+(defconstant afpa-expl #x0D8)
+(defconstant afpa-log10l #x0DE)
+(defconstant afpa-logl #x0DC)
+(defconstant afpa-sinl #x0C0)
+(defconstant afpa-sqrl #x064)
+(defconstant afpa-sqrs #x065)
+(defconstant afpa-tanl #x0C4)
+|#
+
+(defun afpa-fp-reg-p (object)
+  (and (tn-p object)
+       (eq (sb-name (sc-sb (tn-sc object)))
+	   'afpa-float-registers)))
+
+(define-argument-type afpa-fp-reg
+  :type '(satisfies afpa-fp-reg-p)
+  :function tn-offset)
+
+;;; These are really L and ST (load and store word) instructions, but we have
+;;; magic extra arguments to represent the reading and writing of the FP
+;;; registers.  R3 will already have been set up with the high bits of the FP
+;;; instruction by a preceding CAL.
+;;;
+(define-format (afpa-l-inst 32)
+  (fr2 (byte 0 0) :default 0)
+  (fr1 (byte 0 0) :read t)
+  (op (byte 8 24) :default #xCD)
+  (r2 (byte 4 20) :write t)
+  (r3 (byte 4 16) :read t)
+  (i (byte 16 0)))
+;;;
+(define-format (afpa-st-inst 32)
+  (fr2 (byte 0 0) :read t :write t)
+  (fr1 (byte 0 0) :read t)
+  (op (byte 8 24) :default #xDD)
+  (r2 (byte 4 20) :read t)
+  (r3 (byte 4 16) :read t)
+  (i (byte 16 0)))
+
+
+;;; DO-AFPA-INST  --  Internal
+;;;
+;;;    Utility used to emit a afpa operation.  We emit the CAU that sets up
+;;; the high bits of the operation in Temp, and we return the low bits that
+;;; should be passed as the I field of the actual FP operation instruction.
+;;;
+;;; Note: FR2 is the modified register (if any), and the *first* operand to
+;;; binops (I didn't make this up.)
+;;;
+(defun do-afpa-inst (op temp &key fr1 fr2 (ds :register) (ts :pio)
+			data odd)
+  (when fr1
+    (assert (afpa-fp-reg-p fr1)))
+  (when fr2
+    (assert (afpa-fp-reg-p fr2)))
+  (when data
+    (assert (and (tn-p data)
+		 (eq (sb-name (sc-sb (tn-sc data))) 'registers)
+		 (not (and fr1 fr2)))))
+  (when odd (assert data))
+  (let* ((inc (if odd 1 0))
+	 (fr1-offset (if fr1 (+ (tn-offset fr1) inc) 0))
+	 (fr2-offset (if fr2 (+ (tn-offset fr2) inc) 0))
+	 (opcode
+	  (logior (ash (if (eq ts :pio) #xFF #xFE) 24)
+		  (ash (ldb (byte 2 4) fr1-offset) 22)
+		  (ash (ldb (byte 2 4) fr2-offset) 20)
+		  (ash (or (cdr (assoc ds afpa-ds-codes))
+			   (error "Unknown DS code: ~S." ds))
+		       18)
+		  (let ((res (cdr (assoc op afpa-opcodes))))
+		    (if res
+			(ash res 10)
+			(or (cdr (assoc op afpa-special-opcodes))
+			    (error "Unknown opcode: ~S." op))))
+		  (ash (ldb (byte 4 0) fr1-offset) 6)
+		  (ash (ldb (byte 4 0) fr2-offset) 2)
+		  (or (cdr (assoc ts afpa-ts-codes))
+		      (error "Unknown TS code: ~S." ts))))
+	 (low (logand opcode #xFFFF))
+	 (high (+ (logand (ash opcode -16) #xFFFF)
+		  (if (eql (logand low #x8000) 0) 0 1))))
+    (inst cau temp 0 high)
+    low))
+
+
+;;; The AFPA-BINOP pseudo-instruction emits a floating-point binop on the afpa.
+;;; FR2 is the destination float register (and first arg).  FR1 is the source
+;;; float register.  Op is the afpa opcode.  Temp is a sap-reg (i.e. non-zero,
+;;; non-descriptor) register that we form the FP instruction in.
+;;;
+(define-instruction (afpa-binop-inst)
+  (afpa-st-inst
+   (fr2 :argument afpa-fp-reg)
+   (fr1 :argument afpa-fp-reg)
+   (r2 :constant null-offset)
+   (r3 :argument address-register)
+   (i :argument (unsigned-byte 16))))
+;;;
+(define-pseudo-instruction afpa-binop 64 (fr2 fr1 op temp)
+  (inst afpa-binop-inst fr2 fr1 temp
+	(do-afpa-inst op temp :fr1 fr1 :fr2 fr2)))
+
+
+;;; Unop is like binop, but we don't read FR2 before we write it.
+;;;
+(define-instruction (afpa-unop-inst)
+  (afpa-st-inst
+   (fr2 :argument afpa-fp-reg :read nil)
+   (fr1 :argument afpa-fp-reg)
+   (r2 :constant null-offset)
+   (r3 :argument address-register)
+   (i :argument (unsigned-byte 16))))
+
+(define-pseudo-instruction afpa-unop 64 (fr2 fr1 op temp)
+  (inst afpa-unop-inst fr2 fr1 temp
+	(do-afpa-inst op temp :fr1 fr1 :fr2 fr2)))
+
+;;; Sugar up the move a bit...
+(define-pseudo-instruction afpa-move 64 (fr2 fr1 format temp)
+  (inst afpa-unop fr2 fr1
+	(ecase format
+	  (:single :cops)
+	  (:double :copl))
+	temp))
+
+;;; Compare is like binop, but we don't write FR2.
+;;;
+(define-instruction (afpa-compare-inst)
+  (afpa-st-inst
+   (fr2 :argument afpa-fp-reg :write nil)
+   (fr1 :argument afpa-fp-reg)
+   (r2 :constant null-offset)
+   (r3 :argument address-register)
+   (i :argument (unsigned-byte 16))))
+
+(define-pseudo-instruction afpa-compare 64 (fr2 fr1 op temp)
+  (inst afpa-compare-inst fr2 fr1 temp
+	(do-afpa-inst op temp :fr1 fr1 :fr2 fr2)))
+
+
+;;; Noop is used to wait for DMA operations (load and store) to complete.
+;;;
+(define-instruction (afpa-noop-inst :pinned t)
+  (afpa-st-inst
+   (fr1 :constant 0)
+   (fr2 :constant 0)
+   (r2 :constant null-offset)
+   (r3 :argument address-register)
+   (i :argument (unsigned-byte 16))))
+
+(define-pseudo-instruction afpa-noop 64 (temp)
+  (inst afpa-noop-inst temp
+	(do-afpa-inst :noop temp)))
+
+
+;;; Load = WTFR (write float reg) + DMA.
+;;;
+(define-instruction (afpa-load-inst :use (memory))
+  (afpa-st-inst
+   (fr2 :argument afpa-fp-reg :read nil)
+   (fr1 :constant 0)
+   (r2 :argument register)
+   (r3 :argument address-register)
+   (i :argument (unsigned-byte 16))))
+
+(define-pseudo-instruction afpa-load 64 (fr2 data ts temp)
+  (inst afpa-load-inst fr2 data temp
+	(do-afpa-inst :wtfr temp :fr2 fr2 :data data :ts ts)))
+
+
+;;; Store = RDDMA
+;;;
+(define-instruction (afpa-store-inst :clobber (memory))
+  (afpa-st-inst
+   (fr2 :constant 0)
+   (fr1 :argument afpa-fp-reg)
+   (r2 :argument register)
+   (r3 :argument address-register)
+   (i :argument (unsigned-byte 16))))
+
+(define-pseudo-instruction afpa-store 64 (fr1 data ts temp)
+  (inst afpa-store-inst fr1 data temp
+	(do-afpa-inst :rddma temp :fr1 fr1 :data data :ts ts)))
+
+
+;;; Get float = RDFR
+;;;
+(define-instruction (afpa-get-float-inst :clobber (float-status))
+  (afpa-l-inst
+   (fr2 :constant 0)
+   (fr1 :argument afpa-fp-reg)
+   (r2 :argument register)
+   (r3 :argument address-register)
+   (i :argument (unsigned-byte 16))))
+
+(define-pseudo-instruction afpa-get-float 64 (data fr1 temp)
+  (inst afpa-get-float-inst fr1 data temp
+	(do-afpa-inst :rdfr temp :fr1 fr1 :data data)))
+
+(define-pseudo-instruction afpa-get-float-odd 64 (data fr1 temp)
+  (inst afpa-get-float-inst fr1 data temp
+	(do-afpa-inst :rdfr temp :fr1 fr1 :data data :odd t)))
+
+
+;;; Put float = WTFR
+;;;
+(define-instruction (afpa-put-float-inst)
+  (afpa-st-inst
+   (fr2 :argument afpa-fp-reg)
+   (fr1 :constant 0)
+   (r2 :argument register)
+   (r3 :argument address-register)
+   (i :argument (unsigned-byte 16))))
+
+(define-pseudo-instruction afpa-put-float 64 (fr2 data temp)
+  (inst afpa-put-float-inst fr2 data temp
+	(do-afpa-inst :wtfr temp :fr2 fr2 :data data)))
+
+(define-pseudo-instruction afpa-put-float-odd 64 (fr2 data temp)
+  (inst afpa-put-float-inst fr2 data temp
+	(do-afpa-inst :wtfr temp :fr2 fr2 :data data :odd t)))
+
+
+;;; Get status = RDSTR
+;;;
+(define-instruction (afpa-get-status-inst :clobber (float-status))
+  (afpa-l-inst
+   (fr2 :constant 0)
+   (fr1 :constant 0)
+   (r2 :argument register)
+   (r3 :argument address-register)
+   (i :argument (unsigned-byte 16))))
+
+(define-pseudo-instruction afpa-get-status 64 (data temp)
+  (inst afpa-get-status-inst data temp
+	(do-afpa-inst :rdstr temp :data data)))
+
+
+;;; Put status = WTSTR
+;;;
+(define-instruction (afpa-put-status-inst :use (float-status))
+  (afpa-st-inst
+   (fr2 :constant 0)
+   (fr1 :constant 0)
+   (r2 :argument register)
+   (r3 :argument address-register)
+   (i :argument (unsigned-byte 16))))
+
+(define-pseudo-instruction afpa-put-status 64 (data temp)
+  (inst afpa-put-status-inst data temp
+	(do-afpa-inst :wtstr temp :data data)))