Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/code
In directory usw-pr-cvs1:/tmp/cvs-serv9122/src/code

Modified Files:
	early-extensions.lisp symbol.lisp 
Added Files:
	mips-vm.lisp 
Log Message:
0.7.7.9:
	Commit MIPS backend
	... one or two modifications to extant code, as per CSR sbcl-devel
		2002-08-31
	... lots of new files


--- NEW FILE: mips-vm.lisp ---
(in-package "SB!VM")

(define-alien-type os-context-t (struct os-context-t-struct))

;;;; MACHINE-TYPE and MACHINE-VERSION

(defun machine-type ()
  "Returns a string describing the type of the local machine."
  "MIPS")

(defun machine-version ()
  "Returns a string describing the version of the local machine."
  #!+little-endian "little-endian"
  #!-little-endian "big-endian")


;;; FIXUP-CODE-OBJECT -- Interface
;;;
(defun fixup-code-object (code offset value kind)
  (unless (zerop (rem offset n-word-bytes))
    (error "Unaligned instruction?  offset=#x~X." offset))
  (sb!sys:without-gcing
   (let ((sap (truly-the system-area-pointer
			 (%primitive sb!c::code-instructions code))))
     (ecase kind
       (:jump
	(assert (zerop (ash value -28)))
	(setf (ldb (byte 26 0) (sap-ref-32 sap offset))
	      (ash value -2)))
       (:lui
	(setf (sap-ref-16 sap 
			  #!+little-endian offset
			  #!-little-endian (+ offset 2))
	      (+ (ash value -16)
		 (if (logbitp 15 value) 1 0))))
       (:addi
	(setf (sap-ref-16 sap 
			  #!+little-endian offset
			  #!-little-endian (+ offset 2))
	      (ldb (byte 16 0) value)))))))


(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
  (context (* os-context-t)))

(defun context-pc (context)
  (declare (type (alien (* os-context-t)) context))
  ;; KLUDGE: this sucks, and furthermore will break on either of (a)
  ;; porting back to IRIX or (b) running on proper 64-bit support.
  ;; Linux on the MIPS defines its registers in the sigcontext as
  ;; 64-bit quantities ("unsigned long long"), presumably to be
  ;; binary-compatible with 64-bit mode.  Since there appears not to
  ;; be ALIEN support for 64-bit return values, we have to do the
  ;; hacky pointer arithmetic thing.  -- CSR, 2002-09-01
  (int-sap (deref (context-pc-addr context) 
		  #!-little-endian 1
		  ;; Untested
		  #!+little-endian 0)))

(define-alien-routine ("os_context_register_addr" context-register-addr)
  (* unsigned-int)
  (context (* os-context-t))
  (index int))

(define-alien-routine ("os_context_bd_cause" context-bd-cause-int)
    (unsigned 32)
  (context (* os-context-t)))

;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
;;; (Are they used in anything time-critical, or just the debugger?)
(defun context-register (context index)
  (declare (type (alien (* os-context-t)) context))
  (deref (context-register-addr context index) 
	 #!-little-endian 1
	 #!+little-endian 0))

(defun %set-context-register (context index new)
  (declare (type (alien (* os-context-t)) context))
  (setf (deref (context-register-addr context index) 
	       #!-little-endian 1
	       #!+little-endian 0)
	new))

#!+linux
;;; For now.
(defun context-floating-point-modes (context)
  (declare (ignore context))
  (warn "stub CONTEXT-FLOATING-POINT-MODES")
  0)

;;;; Internal-error-arguments.

;;; INTERNAL-ERROR-ARGUMENTS -- interface.
;;;
;;; Given the sigcontext, extract the internal error arguments from the
;;; instruction stream.
;;; 
(defun internal-error-args (context)
  (declare (type (alien (* os-context-t)) context))
  (/show0 "entering INTERNAL-ERROR-ARGS, CONTEXT=..")
  (/hexstr context)
  (let ((pc (context-pc context))
	(cause (context-bd-cause-int context)))
    (declare (type system-area-pointer pc))
    (/show0 "got PC=..")
    (/hexstr (sap-int pc))
    ;; KLUDGE: This exposure of the branch delay mechanism hurts.
    (when (logbitp 31 cause)
      (setf pc (sap+ pc 4)))
    (when (= (sap-ref-8 pc 4) 255)
      (setf pc (sap+ pc 1)))
    (/show0 "now PC=..")
    (/hexstr (sap-int pc))
    (let* ((length (sap-ref-8 pc 4))
	   (vector (make-array length :element-type '(unsigned-byte 8))))
      (declare (type (unsigned-byte 8) length)
	       (type (simple-array (unsigned-byte 8) (*)) vector))
      (/show0 "LENGTH,VECTOR,ERROR-NUMBER=..")
      (/hexstr length)
      (/hexstr vector)
      (copy-from-system-area pc (* n-byte-bits 5)
			     vector (* n-word-bits
				       vector-data-offset)
			     (* length n-byte-bits))
      (let* ((index 0)
	     (error-number (sb!c::read-var-integer vector index)))
	(/hexstr error-number)
	(collect ((sc-offsets))
	 (loop
	  (/show0 "INDEX=..")
	  (/hexstr index)
	  (when (>= index length)
	    (return))
	  (sc-offsets (sb!c::read-var-integer vector index)))
	 (values error-number (sc-offsets)))))))






Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -d -r1.46 -r1.47
--- early-extensions.lisp	14 Aug 2002 13:16:12 -0000	1.46
+++ early-extensions.lisp	1 Sep 2002 22:34:18 -0000	1.47
@@ -40,11 +40,20 @@
 ;;; alpha platform. -- CSR, 2002-06-24
 (def!type unsigned-byte-with-a-bite-out (s bite)
   (cond ((eq s '*) 'integer)
-        ((and (integerp s) (> s 1))
+        ((and (integerp s) (> s 0))
          (let ((bound (ash 1 s)))
            `(integer 0 ,(- bound bite 1))))
         (t
-         (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
+         (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s))))
+
+;;; Motivated by the mips port. -- CSR, 2002-08-22
+(def!type signed-byte-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))))
 
 (def!type load/store-index (scale lowtag min-offset
 				 &optional (max-offset min-offset))

Index: symbol.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/symbol.lisp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- symbol.lisp	5 Mar 2002 03:53:05 -0000	1.12
+++ symbol.lisp	1 Sep 2002 22:34:18 -0000	1.13
@@ -48,12 +48,19 @@
   symbol)
 
 ;;; Return the built-in hash value for SYMBOL.
-#!+(or x86 mips) ;; only backends for which a SYMBOL-HASH vop exists
+
+;;; only backends for which a SYMBOL-HASH vop exists.  In the past,
+;;; when the MIPS backend supported (or nearly did) a generational
+;;; (non-conservative) garbage collector, this read (OR X86 MIPS).
+;;; Having excised the vestigial support for GENGC, this now only
+;;; applies for the x86 port, but if someone were to rework the GENGC
+;;; support, this might change again.  -- CSR, 2002-08-26
+#!+x86 
 (defun symbol-hash (symbol)
   (symbol-hash symbol))
 
 ;;; Compute the hash value for SYMBOL.
-#!-(or x86 mips)
+#!-x86
 (defun symbol-hash (symbol)
   (%sxhash-simple-string (symbol-name symbol)))

Update of /cvsroot/sbcl/sbcl/src/compiler/generic
In directory usw-pr-cvs1:/tmp/cvs-serv9122/src/compiler/generic

Modified Files:
	genesis.lisp 
Log Message:
0.7.7.9:
	Commit MIPS backend
	... one or two modifications to extant code, as per CSR sbcl-devel
		2002-08-31
	... lots of new files


Index: genesis.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/genesis.lisp,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -d -r1.70 -r1.71
--- genesis.lisp	19 Aug 2002 12:14:00 -0000	1.70
+++ genesis.lisp	1 Sep 2002 22:34:18 -0000	1.71
@@ -1740,7 +1740,23 @@
 		  (logior (ash bits 3)
 			  (logand (bvref-32 gspace-bytes gspace-byte-offset)
 				  #xffe0e002)))))))
-      (:ppc
+      (:mips
+       (ecase kind
+	 (:jump
+	  (assert (zerop (ash value -28)))
+	  (setf (ldb (byte 26 0) 
+		     (bvref-32 gspace-bytes gspace-byte-offset))
+		(ash value -2)))
+	 (:lui
+	  (setf (bvref-32 gspace-bytes gspace-byte-offset)
+		(logior (mask-field (byte 16 16) (bvref-32 gspace-bytes gspace-byte-offset))
+			(+ (ash value -16)
+			   (if (logbitp 15 value) 1 0)))))
+	 (:addi
+	  (setf (bvref-32 gspace-bytes gspace-byte-offset)
+		(logior (mask-field (byte 16 16) (bvref-32 gspace-bytes gspace-byte-offset))
+			(ldb (byte 16 0) value))))))
+       (:ppc
        (ecase kind
          (:ba
           (setf (bvref-32 gspace-bytes gspace-byte-offset)

Update of /cvsroot/sbcl/sbcl/src/assembly/mips
In directory usw-pr-cvs1:/tmp/cvs-serv9122/src/assembly/mips

Added Files:
	alloc.lisp arith.lisp array.lisp assem-rtns.lisp support.lisp 
Log Message:
0.7.7.9:
	Commit MIPS backend
	... one or two modifications to extant code, as per CSR sbcl-devel
		2002-08-31
	... lots of new files


--- NEW FILE: alloc.lisp ---
(in-package "SB!VM")



--- NEW FILE: arith.lisp ---
(in-package "SB!VM")


(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 lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst b DO-STATIC-FUN)
  (inst nop)
  #+nil
  (progn
    (inst and temp x 3)
    (inst bne temp DO-STATIC-FUN)
    (inst and temp y 3)
    (inst bne temp DO-STATIC-FUN)
    (inst nop)
    (inst add res x y)
    (lisp-return lra lip :offset 2))

  DO-STATIC-FUN
  (inst lw lip null-tn (static-fun-offset 'two-arg-+))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn))


(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 lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst b DO-STATIC-FUN)
  (inst nop)
  #+nil
  (progn
    (inst and temp x 3)
    (inst bne temp DO-STATIC-FUN)
    (inst and temp y 3)
    (inst bne temp DO-STATIC-FUN)
    (inst nop)
    (inst sub res x y)
    (lisp-return lra lip :offset 2))

  DO-STATIC-FUN
  (inst lw lip null-tn (static-fun-offset 'two-arg--))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn))


(define-assembly-routine (generic-*
			  (:cost 25)
			  (: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 nl4-offset)
			  (:temp lip interior-reg lip-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.
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FUN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FUN)
  (inst nop)

  ;; Remove the tag from one arg so that the result will have the correct
  ;; fixnum tag.
  (inst sra temp x 2)
  (inst mult temp y)
  (inst mflo res)
  (inst mfhi hi)
  ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
  ;; is just 32 copies of the sign bit of the low word).
  (inst sra temp res 31)
  (inst xor temp hi)
  (inst beq temp DONE)
  ;; Shift the double word hi:res down two bits into hi:low to get rid of the
  ;; fixnum tag.
  (inst srl lo res 2)
  (inst sll temp hi 30)
  (inst or lo temp)
  (inst sra hi 2)

  ;; Do we need one word or two?  Assume two.
  (inst sra temp lo 31)
  (inst xor temp hi)
  (inst bne temp two-words)
  ;; Assume a two word header.
  (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))

  ;; Only need one word, fix the header.
  (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))

  (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
    (inst or res alloc-tn other-pointer-lowtag)
    (storew temp res 0 other-pointer-lowtag))

  (storew lo res bignum-digits-offset other-pointer-lowtag)

  ;; Out of here
  (lisp-return lra lip :offset 2)


  TWO-WORDS
  (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
    (inst or res alloc-tn other-pointer-lowtag)
    (storew temp res 0 other-pointer-lowtag))

  (storew lo res bignum-digits-offset other-pointer-lowtag)
  (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)

  ;; Out of here
  (lisp-return lra lip :offset 2)


  DO-STATIC-FUN
  (inst lw lip null-tn (static-fun-offset 'two-arg-*))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn)

  DONE)



;;;; Comparison routines.

(macrolet
    ((define-cond-assem-rtn (name translate static-fn cmp not-p)
       `(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 temp non-descriptor-reg nl0-offset)
				  (:temp lip interior-reg lip-offset)
				  (:temp nargs any-reg nargs-offset)
				  (:temp ocfp any-reg ocfp-offset))
	  (inst and temp x 3)
	  (inst bne temp DO-STATIC-FN)
	  (inst and temp y 3)
	  (inst beq temp DO-COMPARE)
	  ,cmp
	  
	  DO-STATIC-FN
	  (inst lw lip null-tn (static-fun-offset ',static-fn))
	  (inst li nargs (fixnumize 2))
	  (inst move ocfp cfp-tn)
	  (inst j lip)
	  (inst move cfp-tn csp-tn)
	  
	  DO-COMPARE
	  (inst ,(if not-p 'bne 'beq) temp done)
	  (inst move res null-tn)
	  (load-symbol res t)
	  DONE)))

  (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) nil)
  (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) nil))


(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 temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst beq x y RETURN-T)
  (inst and temp x 3)
  (inst beq temp RETURN-NIL)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FN)
  (inst nop)

  RETURN-NIL
  (inst move res null-tn)
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
  (inst lw lip null-tn (static-fun-offset 'eql))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn)

  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 temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FN)
  (inst nop)
  (inst beq x y RETURN-T)

  (inst move res null-tn)
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
  (inst lw lip null-tn (static-fun-offset 'two-arg-=))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn)

  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 temp non-descriptor-reg nl0-offset)
			  (:temp lip interior-reg lip-offset)
			  (:temp lra descriptor-reg lra-offset)
			  (:temp nargs any-reg nargs-offset)
			  (:temp ocfp any-reg ocfp-offset))
  (inst and temp x 3)
  (inst bne temp DO-STATIC-FN)
  (inst and temp y 3)
  (inst bne temp DO-STATIC-FN)
  (inst nop)
  (inst beq x y RETURN-NIL)

  (load-symbol res t)
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
  (inst lw lip null-tn (static-fun-offset 'two-arg-=))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j lip)
  (inst move cfp-tn csp-tn)

  RETURN-NIL
  (inst move res null-tn))

--- NEW FILE: array.lisp ---
(in-package "SB!VM")

(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 nl4-offset))
  ;; This is kinda sleezy, changing words like this.  But we can because
  ;; the vop thinks it is temporary.
  (inst addu words (+ (1- (ash 1 n-lowtag-bits))
		      (* vector-data-offset n-word-bytes)))
  (inst li ndescr (lognot lowtag-mask))
  (inst and words ndescr)
  (inst srl ndescr type word-shift)

  (pseudo-atomic (pa-flag)
    (inst or result alloc-tn other-pointer-lowtag)
    (inst addu alloc-tn words)
    (storew ndescr result 0 other-pointer-lowtag)
    (storew length result vector-length-slot other-pointer-lowtag)))


;;;; Hash primitives

(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 lip interior-reg lip-offset)
			  (:temp accum non-descriptor-reg nl0-offset)
			  (:temp data non-descriptor-reg nl1-offset)
			  (:temp byte non-descriptor-reg nl2-offset)
			  (:temp retaddr non-descriptor-reg nl3-offset))

  ;; These are needed after we jump into sxhash-simple-substring.
  ;;
  ;; FIXME: *BOGGLE* -- CSR, 2002-08-22
  (progn result lip accum data byte retaddr)

  (inst j (make-fixup 'sxhash-simple-substring :assembly-routine))
  (loadw length string vector-length-slot other-pointer-lowtag))

(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 lip interior-reg lip-offset)
			  (:temp accum non-descriptor-reg nl0-offset)
			  (:temp data non-descriptor-reg nl1-offset)
			  (:temp byte non-descriptor-reg nl2-offset)
			  (:temp retaddr non-descriptor-reg nl3-offset))

  ;; Save the return address
  (inst subu retaddr lip code-tn)

  ;; Get a pointer to the data.
  (inst addu lip string
	(- (* vector-data-offset n-word-bytes) other-pointer-lowtag))
  (inst b test)
  (move accum zero-tn)

  loop

  (inst and byte data #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst srl byte data 8)
  (inst and byte byte #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst srl byte data 16)
  (inst and byte byte #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst srl byte data 24)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst addu lip lip 4)

  test

  (inst addu length length (fixnumize -4))
  (inst lw data lip 0)
  (inst bgez length loop)
  (inst nop)

  (inst addu length length (fixnumize 3))
  (inst beq length zero-tn one-more)
  (inst addu length length (fixnumize -1))
  (inst beq length zero-tn two-more)
  (inst addu length length (fixnumize -1))
  (inst bne length zero-tn done)
  (inst nop)

  (ecase *backend-byte-order*
    (:big-endian (inst srl byte data 8))
    (:little-endian (inst srl byte data 16)))
  (inst and byte byte #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  two-more

  (ecase *backend-byte-order*
    (:big-endian (inst srl byte data 16))
    (:little-endian (inst srl byte data 8)))
  (inst and byte byte #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  one-more

  (when (eq *backend-byte-order* :big-endian)
    (inst srl data data 24))
  (inst and byte data #xff)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  done

  (inst sll result accum 5)
  (inst srl result result 3)

  ;; Restore the return address.
  (inst addu lip code-tn retaddr))

--- NEW FILE: assem-rtns.lisp ---
(in-package "SB!VM")


;;;; Return-multiple with other than one value

#+sb-assembling ;; 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 lip interior-reg lip-offset)
     (:temp count any-reg nl2-offset)
     (:temp dst any-reg nl4-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)
     (:temp a4 descriptor-reg a4-offset)
     (:temp a5 descriptor-reg a5-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 blez nvals default-a0-and-on)
  (inst subu count nvals (fixnumize 2))
  (inst blez count default-a2-and-on)
  (inst lw a1 vals (* 1 n-word-bytes))
  (inst subu count (fixnumize 1))
  (inst blez count default-a3-and-on)
  (inst lw a2 vals (* 2 n-word-bytes))
  (inst subu count (fixnumize 1))
  (inst blez count default-a4-and-on)
  (inst lw a3 vals (* 3 n-word-bytes))
  (inst subu count (fixnumize 1))
  (inst blez count default-a5-and-on)
  (inst lw a4 vals (* 4 n-word-bytes))
  (inst subu count (fixnumize 1))
  (inst blez count done)
  (inst lw a5 vals (* 5 n-word-bytes))

  ;; Copy the remaining args to the top of the stack.
  (inst addu vals vals (* 6 n-word-bytes))
  (inst addu dst cfp-tn (* 6 n-word-bytes))

  LOOP
  (inst lw temp vals)
  (inst addu vals n-word-bytes)
  (inst sw temp dst)
  (inst subu count (fixnumize 1))
  (inst bne count zero-tn loop)
  (inst addu dst n-word-bytes)
		
  (inst b done)
  (inst nop)

  DEFAULT-A0-AND-ON
  (inst move a0 null-tn)
  (inst move a1 null-tn)
  DEFAULT-A2-AND-ON
  (inst move a2 null-tn)
  DEFAULT-A3-AND-ON
  (inst move a3 null-tn)
  DEFAULT-A4-AND-ON
  (inst move a4 null-tn)
  DEFAULT-A5-AND-ON
  (inst move a5 null-tn)
  DONE
  
  ;; Clear the stack.
  (move ocfp-tn cfp-tn)
  (move cfp-tn ocfp)
  (inst addu csp-tn ocfp-tn nvals)
  
  ;; Return.
  (lisp-return lra lip))


;;;; tail-call-variable.

#+sb-assembling ;; 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 cfunc-offset)
     (:temp temp descriptor-reg l0-offset)

     ;; Needed for the jump
     (:temp lip interior-reg lip-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)
     (:temp a4 descriptor-reg a4-offset)
     (:temp a5 descriptor-reg a5-offset))


  ;; Calculate NARGS (as a fixnum)
  (inst subu nargs csp-tn args)
     
  ;; Load the argument regs (must do this now, 'cause the blt might
  ;; trash these locations)
  (inst lw a0 args (* 0 n-word-bytes))
  (inst lw a1 args (* 1 n-word-bytes))
  (inst lw a2 args (* 2 n-word-bytes))
  (inst lw a3 args (* 3 n-word-bytes))
  (inst lw a4 args (* 4 n-word-bytes))
  (inst lw a5 args (* 5 n-word-bytes))

  ;; Calc SRC, DST, and COUNT
  (inst addu count nargs (fixnumize (- register-arg-count)))
  (inst blez count done)
  (inst addu src args (* n-word-bytes register-arg-count))
  (inst addu dst cfp-tn (* n-word-bytes register-arg-count))
	
  LOOP
  ;; Copy one arg.
  (inst lw temp src)
  (inst addu src src n-word-bytes)
  (inst sw temp dst)
  (inst addu count (fixnumize -1))
  (inst bgtz count loop)
  (inst addu dst dst n-word-bytes)
	
  DONE
  ;; We are done.  Do the jump.
  (progn
    (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
    (lisp-jump temp lip)))


;;;; Non-local exit noise.

(define-assembly-routine
    (unwind
     (: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 lip interior-reg lip-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 beq block zero-tn error))
  
  (load-symbol-value cur-uwp *current-unwind-protect-block*)
  (loadw target-uwp block unwind-block-current-uwp-slot)
  (inst bne cur-uwp target-uwp do-uwp)
  (inst nop)
      
  (move cur-uwp block)

  do-exit
      
  (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
  (loadw code-tn cur-uwp unwind-block-current-code-slot)
  (progn
    (loadw lra cur-uwp unwind-block-entry-pc-slot)
    (lisp-return lra lip :frob-code nil))

  do-uwp

  (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
  (inst b do-exit)
  (store-symbol-value next-uwp *current-unwind-protect-block*))

(define-assembly-routine
    throw
    ((: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))
  
  (progn start count) ; We just need them in the registers.

  (load-symbol-value catch *current-catch-block*)
  
  loop
  
  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
    (inst beq catch zero-tn error)
    (inst nop))
  
  (loadw tag catch catch-block-tag-slot)
  (inst beq tag target exit)
  (inst nop)
  (loadw catch catch catch-block-previous-catch-slot)
  (inst b loop)
  (inst nop)
  
  exit
  
  (move target catch)
  (inst j (make-fixup 'unwind :assembly-routine))
  (inst nop))

--- NEW FILE: support.lisp ---
(in-package "SB!VM")

(!def-vm-support-routine generate-call-sequence (name style vop)
  (ecase style
    (:raw
     (values
      `((inst jal (make-fixup ',name :assembly-routine))
	(inst nop))
      `()))
    (: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 j (make-fixup ',name :assembly-routine))
	    (inst nop)
	    (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 t)))))
    (:none
     (values
      `((inst j (make-fixup ',name :assembly-routine))
	(inst nop))
      nil))))


(!def-vm-support-routine generate-return-sequence (style)
  (ecase style
    (:raw
     `((inst j lip-tn)
       (inst nop)))
    (:full-call
     `((lisp-return (make-random-tn :kind :normal
				    :sc (sc-or-lose
					 'descriptor-reg)
				    :offset lra-offset)
		    lip-tn :offset 2)))
    (:none)))

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory usw-pr-cvs1:/tmp/cvs-serv9122/src/runtime

Modified Files:
	alpha-linux-os.h hppa-linux-os.h linux-os.h ppc-linux-os.h 
	sparc-linux-os.h x86-linux-os.h 
Added Files:
	Config.mips-linux mips-arch.c mips-arch.h mips-assem.S 
	mips-linux-os.c mips-linux-os.h mips-lispregs.h 
Log Message:
0.7.7.9:
	Commit MIPS backend
	... one or two modifications to extant code, as per CSR sbcl-devel
		2002-08-31
	... lots of new files


--- NEW FILE: Config.mips-linux ---
# This software is part of the SBCL system. See the README file for
# more information.
#
# This software is derived from the CMU CL system, which was
# written at Carnegie Mellon University and released into the
# public domain. The software is in the public domain and is
# provided with absolutely no warranty. See the COPYING and CREDITS
# files for more information.

CFLAGS += -g -O0
LD = ld 
LINKFLAGS = -v -g 
NM = nm -p

ASSEM_SRC = mips-assem.S #hppa-linux-stubs.S
ARCH_SRC = mips-arch.c undefineds.c

OS_SRC = linux-os.c  mips-linux-os.c os-common.c 
LINKFLAGS+=-static
OS_LIBS= -ldl

GC_SRC= cheneygc.c

--- NEW FILE: mips-arch.c ---
/*

 $Header: /cvsroot/sbcl/sbcl/src/runtime/mips-arch.c,v 1.1 2002/09/01 22:34:18 crhodes Exp $

 This code was written as part of the CMU Common Lisp project at
 Carnegie Mellon University, and has been placed in the public domain.

*/

#include <stdio.h>

#include "runtime.h"
#include "arch.h"
#include "sbcl.h"
#include "globals.h"
#include "validate.h"
#include "os.h"
#include "lispregs.h"
#include "signal.h"
#include "alloc.h"
#include "interrupt.h"
#include "interr.h"
#include "breakpoint.h"
#include "monitor.h"

void arch_init()
{
    return;
}

os_vm_address_t arch_get_bad_addr(int signam, siginfo_t *siginfo, os_context_t *context)
{
    /* Classic CMUCL comment:

       Finding the bad address on the mips is easy. */
    return (os_vm_address_t) siginfo->si_addr;
}

unsigned long 
emulate_branch(os_context_t *context, unsigned long inst)
{
    long opcode = inst >> 26;
    long r1 = (inst >> 21) & 0x1f;
    long r2 = (inst >> 16) & 0x1f;
    long bdisp = (inst&(1<<15)) ? inst | (-1 << 16) : inst&0xffff;
    long jdisp = (inst&(1<<25)) ? inst | (-1 << 26) : inst&0xffff;
    long disp = 0;

    switch(opcode) {
    case 0x1: /* bltz, bgez, bltzal, bgezal */
	switch((inst >> 16) & 0x1f) {
	case 0x00: /* bltz */
	    if(*os_context_register_addr(context, r1) < 0)
		disp = bdisp;
	    break;
	case 0x01: /* bgez */
	    if(*os_context_register_addr(context, r1) >= 0)
		disp = bdisp;
	    break;
	case 0x10: /* bltzal */
	    if(*os_context_register_addr(context, r1) < 0)
		disp = bdisp;
	    *os_context_register_addr(context, 31) = *os_context_pc_addr(context) + 4;
	    break;
	case 0x11: /* bgezal */
	    if(*os_context_register_addr(context, r1) >= 0)
		disp = bdisp;
	    *os_context_register_addr(context, 31) = *os_context_pc_addr(context) + 4;
	    break;
	}
	break;
    case 0x4: /* beq */
	if(*os_context_register_addr(context, r1)
	   == *os_context_register_addr(context, r2))
	    disp = bdisp;
	break;
    case 0x5: /* bne */
	if(*os_context_register_addr(context, r1) 
	   != *os_context_register_addr(context, r2))
	    disp = bdisp;
	break;
    case 0x6: /* ble */
	if(*os_context_register_addr(context, r1)
	   /* FIXME: One has to assume that the CMUCL gods of old have
              got the sign issues right... but it might be worth
              checking, someday */
	   <= *os_context_register_addr(context, r2))
	    disp = bdisp;
	break;
    case 0x7: /* bgtz */
	if(*os_context_register_addr(context, r1)
	   >= *os_context_register_addr(context, r2))
	    disp = bdisp;
	break;
    case 0x2: /* j */
	disp = jdisp;
	break;
    case 0x3: /* jal */
	disp = jdisp;
	*os_context_register_addr(context, 31) = *os_context_pc_addr(context) + 4;
	break;
    }
    return (*os_context_pc_addr(context) + disp * 4);
}

void arch_skip_instruction(os_context_t *context)
{
    /* Skip the offending instruction */
    if (os_context_bd_cause(context))
        *os_context_pc_addr(context) = 
	    emulate_branch(context, 
			   *(unsigned long *) *os_context_pc_addr(context));
    else
        *os_context_pc_addr(context) += 4;

    os_flush_icache((os_vm_address_t) *os_context_pc_addr(context), sizeof(unsigned long));
}

unsigned char *arch_internal_error_arguments(os_context_t *context)
{
    if (os_context_bd_cause(context))
	return (unsigned char *)(*os_context_pc_addr(context) + 8);
    else
	return (unsigned char *)(*os_context_pc_addr(context) + 4);
}

boolean arch_pseudo_atomic_atomic(os_context_t *context)
{
    return *os_context_register_addr(context, reg_ALLOC) & 1;
}

#define PSEUDO_ATOMIC_INTERRUPTED_BIAS 0x7f000000

void arch_set_pseudo_atomic_interrupted(os_context_t *context)
{
    *os_context_register_addr(context, reg_NL4) |= 1<<31;
}

unsigned long arch_install_breakpoint(void *pc)
{
    unsigned long *ptr = (unsigned long *)pc;
    unsigned long result = *ptr;
    *ptr = (trap_Breakpoint << 16) | 0xd;

    os_flush_icache((os_vm_address_t)ptr, sizeof(unsigned long));

    return result;
}

void arch_remove_breakpoint(void *pc, unsigned long orig_inst)
{
    *(unsigned long *)pc = orig_inst;

    os_flush_icache((os_vm_address_t)pc, sizeof(unsigned long));
}

static unsigned long *skipped_break_addr, displaced_after_inst;
static sigset_t orig_sigmask;

void arch_do_displaced_inst(os_context_t *context,
			    unsigned int orig_inst)
{
    unsigned long *pc = (unsigned long *)*os_context_pc_addr(context);
    unsigned long *break_pc, *next_pc;
    unsigned long next_inst;
    int opcode;

    orig_sigmask = *os_context_sigmask_addr(context);
    sigaddset_blockable(os_context_sigmask_addr(context));

    /* Figure out where the breakpoint is, and what happens next. */
    if (os_context_bd_cause(context)) {
	break_pc = pc+1;
	next_inst = *pc;
    }
    else {
	break_pc = pc;
	next_inst = orig_inst;
    }

    /* Put the original instruction back. */
    *break_pc = orig_inst;
    os_flush_icache((os_vm_address_t)break_pc, sizeof(unsigned long));
    skipped_break_addr = break_pc;

    /* Figure out where it goes. */
    opcode = next_inst >> 26;
    if (opcode == 1 || ((opcode & 0x3c) == 0x4) || ((next_inst & 0xf00e0000) == 0x80000000)) {
        
        next_pc = emulate_branch(context, next_inst);
    }
    else
	next_pc = pc+1;

    displaced_after_inst = *next_pc;
    *next_pc = (trap_AfterBreakpoint << 16) | 0xd;
    os_flush_icache((os_vm_address_t)next_pc, sizeof(unsigned long));
}

static void sigtrap_handler(int signal, siginfo_t *info, void *void_context)
{
    os_context_t *context = arch_os_get_context(&void_context);
    sigset_t *mask;
    int code;
    /* Don't disallow recursive breakpoint traps.  Otherwise, we can't */
    /* use debugger breakpoints anywhere in here. */
    mask = os_context_sigmask_addr(context);
    sigsetmask(mask);
    code = ((*(int *) (*os_context_pc_addr(context))) >> 16) & 0x1f;

    switch (code) {
    case trap_PendingInterrupt:
	arch_skip_instruction(context);
	interrupt_handle_pending(context);
	break;
	
    case trap_Halt:
	fake_foreign_function_call(context);
	lose("%%primitive halt called; the party is over.\n");
	
    case trap_Error:
    case trap_Cerror:
	interrupt_internal_error(signal, info, context, code==trap_Cerror);
	break;
	
    case trap_Breakpoint:
	handle_breakpoint(signal, info, context);
	break;
	
    case trap_FunEndBreakpoint:
	*os_context_pc_addr(context) = (int)handle_fun_end_breakpoint(signal, info, context);
	break;
	
    case trap_AfterBreakpoint:
	*skipped_break_addr = (trap_Breakpoint << 16) | 0xd;
	os_flush_icache((os_vm_address_t)skipped_break_addr,
			sizeof(unsigned long));
	skipped_break_addr = NULL;
	*(unsigned long *)(*os_context_pc_addr(context)) = displaced_after_inst;
	os_flush_icache((os_vm_address_t) *os_context_pc_addr(context), sizeof(unsigned long));
	*os_context_sigmask_addr(context) = orig_sigmask;
	break;

    case 0x10:
	/* Clear the flag */
	*os_context_register_addr(context, reg_NL4) &= 0x7fffffff;
	arch_skip_instruction(context);
	interrupt_handle_pending(context);
	return;
	
    default:
	interrupt_handle_now(signal, info, context);
	break;
    }
}

/* FIXME: We must have one of these somewhere. Also, export
   N-FIXNUM-TAG-BITS from Lispland and use it rather than 2 here. */
#define FIXNUM_VALUE(lispobj) (((int)lispobj)>>2)

void sigfpe_handler(int signal, siginfo_t *info, void *void_context)
{
    unsigned long bad_inst;
    unsigned int op, rs, rt, rd, funct, dest;
    int immed;
    long result;
    os_context_t *context = arch_os_get_context(&void_context);

    if (os_context_bd_cause(context))
        bad_inst = *(unsigned long *)(*os_context_pc_addr(context) + 4);
    else
        bad_inst = *(unsigned long *)(*os_context_pc_addr(context));

    op = (bad_inst >> 26) & 0x3f;
    rs = (bad_inst >> 21) & 0x1f;
    rt = (bad_inst >> 16) & 0x1f;
    rd = (bad_inst >> 11) & 0x1f;
    funct = bad_inst & 0x3f;
    immed = (((int)(bad_inst & 0xffff)) << 16) >> 16;

    switch (op) {
    case 0x0: /* SPECIAL */
	switch (funct) {
	case 0x20: /* ADD */
	    /* FIXME: Hopefully, this whole section can just go away,
               with the rewrite of pseudo-atomic and the deletion of
               overflow VOPs */
	    /* Check to see if this is really a pa_interrupted hit */
	    if (rs == reg_ALLOC && rt == reg_NL4) {
		*os_context_register_addr(context, reg_ALLOC)
		    += (*os_context_register_addr(context, reg_NL4)
			- PSEUDO_ATOMIC_INTERRUPTED_BIAS);
		arch_skip_instruction(context);
		interrupt_handle_pending(context);
		return;
	    }
	    result = FIXNUM_VALUE(*os_context_register_addr(context, rs))
		+ FIXNUM_VALUE(*os_context_register_addr(context, rt));
	    dest = rd;
	    break;
	    
	case 0x22: /* SUB */
	    result = FIXNUM_VALUE(*os_context_register_addr(context, rs))
		- FIXNUM_VALUE(*os_context_register_addr(context, rt));
	    dest = rd;
	    break;
	    
	default:
	    dest = 32;
	    break;
	}
	break;
	
    case 0x8: /* ADDI */
	result = FIXNUM_VALUE(*os_context_register_addr(context,rs)) + (immed>>2);
	dest = rt;
	break;
	
    default:
	dest = 32;
	break;
    }
    
    if (dest < 32) {
        dynamic_space_free_pointer =
            (lispobj *) *os_context_register_addr(context,reg_ALLOC);

        *os_context_register_addr(context,dest) = alloc_number(result);

	*os_context_register_addr(context, reg_ALLOC) =
	    (unsigned long) dynamic_space_free_pointer;
	
        arch_skip_instruction(context);
	
    }
    else
        interrupt_handle_now(signal, info, context);
}

void arch_install_interrupt_handlers()
{    
    undoably_install_low_level_interrupt_handler(SIGTRAP,sigtrap_handler);
    undoably_install_low_level_interrupt_handler(SIGFPE,sigfpe_handler);
}

extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);

lispobj funcall0(lispobj function)
{
    lispobj *args = current_control_stack_pointer;

    return call_into_lisp(function, args, 0);
}

lispobj funcall1(lispobj function, lispobj arg0)
{
    lispobj *args = current_control_stack_pointer;

    current_control_stack_pointer += 1;
    args[0] = arg0;

    return call_into_lisp(function, args, 1);
}

lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1)
{
    lispobj *args = current_control_stack_pointer;

    current_control_stack_pointer += 2;
    args[0] = arg0;
    args[1] = arg1;

    return call_into_lisp(function, args, 2);
}

lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
{
    lispobj *args = current_control_stack_pointer;

    current_control_stack_pointer += 3;
    args[0] = arg0;
    args[1] = arg1;
    args[2] = arg2;

    return call_into_lisp(function, args, 3);
}


--- NEW FILE: mips-arch.h ---
#ifndef _MIPS_ARCH_H
#define _MIPS_ARCH_H

#endif /* _MIPS_ARCH_H */

--- NEW FILE: mips-assem.S ---
#define LANGUAGE_ASSEMBLY

#include "sbcl.h"	
#include "lispregs.h"
	
#define zero $0
#define at $1
#define v0 $2
#define v1 $3
#define a0 $4
#define a1 $5
#define a2 $6
#define a3 $7
#define t0 $8
#define t1 $9
#define t2 $10
#define t3 $11
#define t4 $12
#define t5 $13
#define t6 $14
#define t7 $15
#define s0 $16
#define s1 $17
#define s2 $18
#define s3 $19
#define s4 $20
#define s5 $21
#define s6 $22
#define s7 $23
#define t8 $24
#define t9 $25
#define k0 $26
#define k1 $27
#define gp $28
#define sp $29
#define s8 $30
#define ra $31

	
/*
 * Function to transfer control into lisp.
 */
	.text
	.globl	call_into_lisp
	.ent	call_into_lisp
call_into_lisp:
#define framesize 12*4
	subu	sp, framesize
	.frame	sp, framesize, ra
	/* Save all the C regs. */
	.mask	0xc0ff0000, 0
	sw	ra, framesize(sp)
	sw	s8, framesize-4(sp)
	sw	s7, framesize-12(sp)
	sw	s6, framesize-16(sp)
	sw	s5, framesize-20(sp)
	sw	s4, framesize-24(sp)
	sw	s3, framesize-28(sp)
	sw	s2, framesize-32(sp)
	sw	s1, framesize-36(sp)
	sw	s0, framesize-40(sp)

	/* Clear descriptor regs */
	move	t0, zero
	move	t1, zero
	move	t2, zero
	move	t3, zero
	move	t4, zero
	move	t5, zero
	move	t6, zero
	move	t7, zero
	move	t8, zero
	move	s0, zero
	move	s1, zero
	move	s2, zero
	move	s3, zero
	move	ra, zero

	li	reg_NIL, NIL

	/* Start pseudo-atomic. */
	.set	noreorder
	li	reg_NL4, 0
	li	reg_ALLOC, 1
        .set    reorder

	/* No longer in foreign call. */
	sw	zero, foreign_function_call_active

	/* Load the allocation pointer, preserving the low-bit of alloc */
	lw	reg_BSP, dynamic_space_free_pointer
	add	reg_ALLOC, reg_BSP

	/* Load the rest of the LISP state. */
	lw	reg_BSP, current_binding_stack_pointer
	lw	reg_CSP, current_control_stack_pointer
	lw	reg_OCFP, current_control_frame_pointer

	/* Check for interrupt */
        .set    noreorder
	bgez	reg_NL4, pa1
	nop
	break	0x10
pa1:
	subu	reg_ALLOC, 1
	.set	reorder

	/* Pass in args */
	move	reg_LEXENV, $4
	move	reg_CFP, $5
	sll	reg_NARGS, $6, 2
	lw	reg_A0, 0(reg_CFP)
	lw	reg_A1, 4(reg_CFP)
	lw	reg_A2, 8(reg_CFP)
	lw	reg_A3, 12(reg_CFP)
	lw	reg_A4, 16(reg_CFP)
	lw	reg_A5, 20(reg_CFP)

	/* Calculate LRA */
	la	reg_LRA, lra + OTHER_POINTER_LOWTAG

	/* Indirect closure */
	lw	reg_CODE, -1(reg_LEXENV)

	/* Jump into lisp land. */
	addu	reg_LIP, reg_CODE, 6*4 - FUN_POINTER_LOWTAG
	j	reg_LIP

	.set	noreorder
	.align	3
#ifdef irix
	/* This particular KLUDGE is kept here as a reminder; for more
	details, see irix-asm-munge.c from CMUCL's lisp directory.
	Other examples have been deleted from later in the file in the
	hope that they will not be needed. */
.globl  mipsmungelra /* for our munging afterwards in irix-asm-munge */
mipsmungelra:
#endif
lra:
	.word	RETURN_PC_HEADER_WIDETAG

	/* Multiple value return spot, clear stack */
	move	reg_CSP, reg_OCFP
	nop

	/* Set pseudo-atomic flag. */
	li	reg_NL4, 0
	addu	reg_ALLOC, 1
	.set	reorder

	/* Save LISP registers. */
	subu	reg_NL0, reg_ALLOC, 1
	sw	reg_NL0, dynamic_space_free_pointer
	sw	reg_BSP, current_binding_stack_pointer
	sw	reg_CSP, current_control_stack_pointer
	sw	reg_CFP, current_control_frame_pointer

	/* Pass one return value back to C land. */ 
	/* v0 is reg_ALLOC in this new world, so do this after saving
           reg_ALLOC in dynamic_space_free_pointer */
	move	v0, reg_A0

	/* Back in foreign function call */
	sw	reg_CFP, foreign_function_call_active

	/* Check for interrupt */
	.set	noreorder
	bgez	reg_NL4, pa2
	nop
	break	0x10
pa2:
	subu	reg_ALLOC, 1
	.set	reorder

	/* Restore C regs */
	lw	ra, framesize(sp)
	lw	s8, framesize-4(sp)
	lw	s7, framesize-12(sp)
	lw	s6, framesize-16(sp)
	lw	s5, framesize-20(sp)
	lw	s4, framesize-24(sp)
	lw	s3, framesize-28(sp)
	lw	s2, framesize-32(sp)
	lw	s1, framesize-36(sp)
	lw	s0, framesize-40(sp)

	/* Restore C stack. */
	addu	sp, framesize

	/* Back we go. */
	j	ra

	.end	call_into_lisp

/*
 * Transfering control from Lisp into C
 */
	.text
	.globl	call_into_c
	.ent	call_into_c
call_into_c:
	/* Set up a stack frame. */
	move	reg_OCFP, reg_CFP
	move	reg_CFP, reg_CSP
	addu	reg_CSP, reg_CFP, 32
	sw	reg_OCFP, 0(reg_CFP)
	subu	reg_NL4, reg_LIP, reg_CODE
	addu	reg_NL4, OTHER_POINTER_LOWTAG
	sw	reg_NL4, 4(reg_CFP)
	sw	reg_CODE, 8(reg_CFP)
        sw      gp, 12(reg_CFP)

	/* Note: the C stack is already set up. */

	/* Set the pseudo-atomic flag. */
	.set	noreorder
	li	reg_NL4, 0
	addu	reg_ALLOC, 1
	.set	reorder

	/* Save lisp state. */
	subu	t0, reg_ALLOC, 1
	sw	t0, dynamic_space_free_pointer
	sw	reg_BSP, current_binding_stack_pointer
	sw	reg_CSP, current_control_stack_pointer
	sw	reg_CFP, current_control_frame_pointer

	/* Mark us as in C land. */
	sw	reg_CSP, foreign_function_call_active

	/* Were we interrupted? */
	.set	noreorder
	bgez	reg_NL4, pa3
	nop
	break	0x10
pa3:
	subu	reg_ALLOC, 1
	.set	reorder

	/* Into C land we go. */
	move    t9, reg_CFUNC
	jal	t9
	nop

	lw      gp, 12(reg_CFP)
	
	/* Clear unsaved descriptor regs */
	move	t0, zero
	move	t1, zero
	move	t2, zero
	move	t3, zero
	move	t4, zero
	move	t5, zero
	move	t6, zero
	move	t7, zero
	move	t8, zero
	move	s0, zero
	move	s2, zero
	move	s3, zero
	move	ra, zero

	/* Turn on pseudo-atomic. */
	.set	noreorder
	li	reg_NL4, 0
	li	reg_ALLOC, 1
	.set	reorder

	/* Mark us at in Lisp land. */
	sw	zero, foreign_function_call_active

	/* Restore ALLOC, preserving pseudo-atomic-atomic */
	lw	a0, dynamic_space_free_pointer
	addu	reg_ALLOC, a0

	/* Check for interrupt */
	.set	noreorder
	bgez	reg_NL4, pa4
	nop
	break	0x10
pa4:
	subu	reg_ALLOC, 1
	.set	reorder

	/* Restore LRA & CODE (they may have been GC'ed) */
	lw	reg_CODE, 8(reg_CFP)
	lw	a0, 4(reg_CFP)
	subu	a0, OTHER_POINTER_LOWTAG
	addu	reg_LIP, reg_CODE, a0

	/* Reset the lisp stack. */
	/* Note: OCFP and CFP are in saved regs. */
	move	reg_CSP, reg_CFP
	move	reg_CFP, reg_OCFP

	/* Return to LISP. */
	j	reg_LIP

	.end	call_into_c

	.text
	.globl	start_of_tramps
start_of_tramps:

/*
 * The undefined-function trampoline.
 */
        .text
        .globl  undefined_tramp
        .ent    undefined_tramp
undefined_tramp:
        break   10
        .byte    4
        .byte    UNDEFINED_FUN_ERROR
        .byte    254
        .byte    (0xc0 + sc_DescriptorReg)
        .byte    1
        .align 2
        .end    undefined_tramp

/*
 * The closure trampoline.
 */
        .text
        .globl  closure_tramp
        .ent    closure_tramp
closure_tramp:
        lw      reg_LEXENV, FDEFN_FUN_OFFSET(reg_FDEFN)
        lw      reg_L0, CLOSURE_FUN_OFFSET(reg_LEXENV)
        addu    reg_LIP, reg_L0, SIMPLE_FUN_CODE_OFFSET
        j       reg_LIP
        .end    closure_tramp

	.text
	.globl	end_of_tramps
end_of_tramps:


/*
 * Function-end breakpoint magic.
 */

	.text
	.align	2
	.set	noreorder
	.globl	function_end_breakpoint_guts
fun_end_breakpoint_guts:
	.word	RETURN_PC_HEADER_WIDETAG
	
	beq	zero, zero, 1f
	nop
	move	reg_OCFP, reg_CSP
	addu	reg_CSP, 4
	li	reg_NARGS, 4
	move	reg_A1, reg_NIL
	move	reg_A2, reg_NIL
	move	reg_A3, reg_NIL
	move	reg_A4, reg_NIL
	move	reg_A5, reg_NIL
1:

	.globl	fun_end_breakpoint_trap
fun_end_breakpoint_trap:
	break	trap_FunEndBreakpoint
	beq	zero, zero, 1b
	nop

	.globl	fun_end_breakpoint_end
fun_end_breakpoint_end:
	.set	reorder

/* FIXME:	 I don't think the below are actually used anywhere */
	.text
	.align	2
	.globl	call_on_stack
	.ent	call_on_stack
call_on_stack:
	subu	sp, a1, 16
	jal	a0
	break	0
	.end	call_on_stack

	.globl	save_state
	.ent	save_state
save_state:
	subu	sp, 40
	.frame	sp, 40, ra
	/* Save all the C regs. */
	.mask	0xc0ff0000, 0
	sw	ra, 40(sp)
	sw	s8, 40-4(sp)
	sw	s7, 40-8(sp)
	sw	s6, 40-12(sp)
	sw	s5, 40-16(sp)
	sw	s4, 40-20(sp)
	sw	s3, 40-24(sp)
	sw	s2, 40-28(sp)
	sw	s1, 40-32(sp)
	sw	s0, 40-36(sp)

	/* Should also save the floating point state. */

	move	t0, a0
	move	a0, sp

	jal	t0

_restore_state:

	lw	ra, 40(sp)
	lw	s8, 40-4(sp)
	lw	s7, 40-8(sp)
	lw	s6, 40-12(sp)
	lw	s5, 40-16(sp)
	lw	s4, 40-20(sp)
	lw	s3, 40-24(sp)
	lw	s2, 40-28(sp)
	lw	s1, 40-32(sp)
	lw	s0, 40-36(sp)

	addu	sp, 40
	j	ra

	.globl	restore_state
restore_state:
	move	sp, a0
	move	v0, a1
	j	_restore_state
	.end	save_state






--- NEW FILE: mips-linux-os.c ---
/*
 * This is the MIPS Linux incarnation of arch-dependent OS-dependent
 * routines. See also "linux-os.c".
 */

/*
 * This software is part of the SBCL system. See the README file for
 * more information.
 *
 * This software is derived from the CMU CL system, which was
 * written at Carnegie Mellon University and released into the
 * public domain. The software is in the public domain and is
 * provided with absolutely no warranty. See the COPYING and CREDITS
 * files for more information.
 */

#include <stdio.h>
#include <sys/param.h>
#include <sys/file.h>
#include "./signal.h"
#include "os.h"
#include "arch.h"
#include "globals.h"
#include "interrupt.h"
#include "interr.h"
#include "lispregs.h"
#include "sbcl.h"
#include <sys/socket.h>
#include <sys/utsname.h>

#include <sys/types.h>
#include <signal.h>
#include <sys/time.h>
#include <sys/stat.h>
#include <unistd.h>

#include "validate.h"
/* for cacheflush() */
#include <asm/cachectl.h>

/* FIXME: For CAUSEF_BD */
#include <asm/mipsregs.h>
size_t os_vm_page_size;


os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
{
    if (offset == 0) {
	/* KLUDGE: I'm not sure, but it's possible that Linux puts the
           contents of the Processor Status Word in the (wired-zero)
           slot in the mcontext. In any case, the following is
           unlikely to do any harm: */
	static unsigned long long zero;
	zero = 0;
	return &zero;
    } else {
	return &(((struct sigcontext *) &(context->uc_mcontext))->sc_regs[offset]);
    }
}

os_context_register_t *
os_context_pc_addr(os_context_t *context)
{
    /* Why do I get all the silly ports? -- CSR, 2002-08-11 */
    return &(((struct sigcontext *) &(context->uc_mcontext))->sc_pc);
}

sigset_t *
os_context_sigmask_addr(os_context_t *context)
{
    return &(context->uc_sigmask);
}

void 
os_restore_fp_control(os_context_t *context)
{
    /* FIXME: Probably do something. */
}

unsigned int
os_context_bd_cause(os_context_t *context)
{
    /* We need to see if whatever happened, happened because of a
       branch delay event */
    return (((struct sigcontext *) &(context->uc_mcontext))->sc_cause 
	    & CAUSEF_BD);
}

void 
os_flush_icache(os_vm_address_t address, os_vm_size_t length)
{
    if (cacheflush(address, length, ICACHE) == -1)
	perror("cacheflush");
}

--- NEW FILE: mips-linux-os.h ---
#ifndef _MIPS_LINUX_OS_H
#define _MIPS_LINUX_OS_H

typedef struct ucontext os_context_t;
typedef unsigned long long os_context_register_t;

static inline os_context_t *arch_os_get_context(void **void_context) {
    return (os_context_t *) *void_context;
}

unsigned long os_context_fp_control(os_context_t *context);
void os_restore_fp_control(os_context_t *context);
unsigned int os_context_bd_cause(os_context_t *context);

#endif /* _MIPS_LINUX_OS_H */

--- NEW FILE: mips-lispregs.h ---
/* $Header: /cvsroot/sbcl/sbcl/src/runtime/mips-lispregs.h,v 1.1 2002/09/01 22:34:18 crhodes Exp $ */

#ifdef LANGUAGE_ASSEMBLY
#define REG(num) $ ## num
#else
#define REG(num) num
#endif

#define NREGS	(32)

#define reg_ZERO    REG(0)
#define reg_NL3     REG(1)
#define reg_CFUNC   REG(2)
#define reg_NL4     REG(3)
#define reg_NL0     REG(4)
#define reg_NL1     REG(5)
#define reg_NL2     REG(6)
#define reg_NARGS   REG(7)
#define reg_A0      REG(8)
#define reg_A1      REG(9)
#define reg_A2      REG(10)
#define reg_A3      REG(11)
#define reg_A4      REG(12)
#define reg_A5      REG(13)
#define reg_FDEFN   REG(14)
#define reg_LEXENV  REG(15)
#define reg_NFP     REG(16)
#define reg_OCFP    REG(17)
#define reg_LRA     REG(18)
#define reg_L0      REG(19)
#define reg_NIL     REG(20)
#define reg_BSP     REG(21)
#define reg_CFP     REG(22)
#define reg_CSP     REG(23)
#define reg_L1      REG(24)
#define reg_ALLOC   REG(25)
#define reg_NSP     REG(29)
#define reg_CODE    REG(30)
#define reg_LIP     REG(31)

#define REGNAMES \
	"ZERO",		"NL3",		"CFUNC",	"NL4", \
	"NL0",		"NL1",		"NL2",		"NARGS", \
	"A0",		"A1",		"A2",		"A3", \
	"A4",		"A5",		"FDEFN",       	"LEXENV", \
	"NFP",		"OCFP",		"LRA",		"L0", \
	"NIL",		"BSP",		"CFP",		"CSP", \
	"L1",		"ALLOC",	"K0",		"K1", \
	"GP",		"NSP",		"CODE",		"LIP"


#define BOXED_REGISTERS { \
    reg_A0, reg_A1, reg_A2, reg_A3, reg_A4, reg_A5, reg_FDEFN, reg_LEXENV, \
    reg_NFP, reg_OCFP, reg_LRA, reg_L0, reg_L1, reg_CODE \
}

#define SC_REG(sc, n) ((sc)->sc_regs[n])
#define SC_PC(sc) ((sc)->sc_pc)

Index: alpha-linux-os.h
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/alpha-linux-os.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- alpha-linux-os.h	18 Jul 2002 17:47:34 -0000	1.3
+++ alpha-linux-os.h	1 Sep 2002 22:34:18 -0000	1.4
@@ -2,6 +2,7 @@
 #define _ALPHA_LINUX_OS_H
 
 typedef struct ucontext os_context_t;
+typedef long os_context_register_t;
 
 static inline os_context_t *arch_os_get_context(void **void_context) {
     return (os_context_t *) *void_context;

Index: hppa-linux-os.h
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/hppa-linux-os.h,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- hppa-linux-os.h	19 Aug 2002 12:14:03 -0000	1.1
+++ hppa-linux-os.h	1 Sep 2002 22:34:18 -0000	1.2
@@ -2,6 +2,9 @@
 #define _HPPA_LINUX_OS_H
 
 typedef struct ucontext os_context_t;
+/* FIXME: This will change if the parisc-linux people implement
+   wide-sigcontext for 32-bit kernels */
+typedef unsigned long os_context_register_t;
 
 static inline os_context_t *arch_os_get_context(void **void_context) {
     return (os_context_t *) *void_context;

Index: linux-os.h
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/linux-os.h,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- linux-os.h	23 Jul 2002 17:22:37 -0000	1.6
+++ linux-os.h	1 Sep 2002 22:34:18 -0000	1.7
@@ -38,5 +38,3 @@
 
 #define SIG_MEMORY_FAULT SIGSEGV
 
-/* /usr/include/asm/sigcontext.h  */
-typedef long os_context_register_t ;

Index: ppc-linux-os.h
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/ppc-linux-os.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- ppc-linux-os.h	18 Jul 2002 17:47:34 -0000	1.3
+++ ppc-linux-os.h	1 Sep 2002 22:34:18 -0000	1.4
@@ -2,6 +2,7 @@
 #define _PPC_LINUX_OS_H
 
 typedef struct ucontext os_context_t;
+typedef long os_context_register_t;
 
 static inline os_context_t *arch_os_get_context(void **void_context) {
     return (os_context_t *) *void_context;

Index: sparc-linux-os.h
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/sparc-linux-os.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- sparc-linux-os.h	18 Jul 2002 17:47:34 -0000	1.3
+++ sparc-linux-os.h	1 Sep 2002 22:34:18 -0000	1.4
@@ -2,6 +2,7 @@
 #define _SPARC_LINUX_OS_H
 
 typedef struct sigcontext os_context_t;
+typedef unsigned long os_context_register_t;
 
 static inline os_context_t *arch_os_get_context(void **void_context) {
     asm volatile ("ta 0x03"); /* ta ST_FLUSH_WINDOWS */

Index: x86-linux-os.h
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/x86-linux-os.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- x86-linux-os.h	18 Jul 2002 17:47:34 -0000	1.3
+++ x86-linux-os.h	1 Sep 2002 22:34:18 -0000	1.4
@@ -2,6 +2,7 @@
 #define _X86_LINUX_OS_H
 
 typedef struct ucontext os_context_t;
+typedef long os_context_register_t;
 
 static inline os_context_t *arch_os_get_context(void **void_context) {
     return (os_context_t *) *void_context;

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv9122

Modified Files:
	build-order.lisp-expr make-config.sh 
	package-data-list.lisp-expr version.lisp-expr 
Log Message:
0.7.7.9:
	Commit MIPS backend
	... one or two modifications to extant code, as per CSR sbcl-devel
		2002-08-31
	... lots of new files


Index: build-order.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/build-order.lisp-expr,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- build-order.lisp-expr	13 Jun 2002 08:54:37 -0000	1.16
+++ build-order.lisp-expr	1 Sep 2002 22:34:13 -0000	1.17
@@ -207,15 +207,15 @@
  
  ;; KLUDGE: I'd prefer to have this done with a "code/target" softlink
  ;; instead of a bunch of reader macros. -- WHN 19990308
- #!+pmax ("src/code/pmax-vm" :not-host)
- #!+(and sparc svr4) ("src/code/sparc-svr4-vm" :not-host)
- #!+(and sparc (not svr4)) ("src/code/sparc-vm" :not-host)
- #!+rt    ("src/code/rt-vm"    :not-host)
+ #!+sparc ("src/code/sparc-vm" :not-host)
  #!+hppa  ("src/code/hppa-vm"  :not-host)
  #!+x86   ("src/code/x86-vm"   :not-host)
  #!+ppc   ("src/code/ppc-vm"   :not-host)
  #!+alpha ("src/code/alpha-vm" :not-host)
- #!+sgi   ("src/code/sgi-vm"   :not-host)
+ #!+mips  ("src/code/mips-vm"  :not-host)
+
+ ;; FIXME: do we really want to keep this? -- CSR, 2002-08-31
+ #!+rt    ("src/code/rt-vm"    :not-host)
 
  ("src/code/target-signal" :not-host) ; needs OS-CONTEXT-T from x86-vm
 

Index: make-config.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/make-config.sh,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -d -r1.15 -r1.16
--- make-config.sh	19 Aug 2002 12:14:00 -0000	1.15
+++ make-config.sh	1 Sep 2002 22:34:17 -0000	1.16
@@ -36,6 +36,8 @@
     sun*) guessed_sbcl_arch=sparc ;;
     ppc) guessed_sbcl_arch=ppc ;;
     parisc) guessed_sbcl_arch=hppa ;;
+    mips) guessed_sbcl_arch=mips ;;
+    mipsel) guessed_sbcl_arch=mips; little_endian=yes ;;
     *)
         # If we're not building on a supported target architecture, we
 	# we have no guess, but it's not an error yet, since maybe
@@ -62,6 +64,8 @@
 # similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
 if [ "$sbcl_arch" = "x86" ] ; then
     printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
+elif [ "$sbcl_arch" = "mips" -a "$little_endian" = "yes" ] ; then
+    printf ' :little-endian' >> $ltf
 else
     # Nothing need be done in this case, but sh syntax wants a placeholder.
     echo > /dev/null

Index: package-data-list.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/package-data-list.lisp-expr,v
retrieving revision 1.171
retrieving revision 1.172
diff -u -d -r1.171 -r1.172
--- package-data-list.lisp-expr	31 Aug 2002 01:19:50 -0000	1.171
+++ package-data-list.lisp-expr	1 Sep 2002 22:34:17 -0000	1.172
@@ -750,6 +750,7 @@
 	     
              ;; ..and DEFTYPEs..
              "INDEX" "LOAD/STORE-INDEX"
+	     "SIGNED-BYTE-WITH-A-BITE-OUT"
 	     "UNSIGNED-BYTE-WITH-A-BITE-OUT"
              ;; ..and type predicates
              "INSTANCEP"

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.519
retrieving revision 1.520
diff -u -d -r1.519 -r1.520
--- version.lisp-expr	1 Sep 2002 21:49:02 -0000	1.519
+++ version.lisp-expr	1 Sep 2002 22:34:17 -0000	1.520
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.7.8"
+"0.7.7.9"

Update of /cvsroot/sbcl/sbcl/src/assembly/mips
In directory usw-pr-cvs1:/tmp/cvs-serv3028/src/assembly/mips

Log Message:
Directory /cvsroot/sbcl/sbcl/src/assembly/mips added to the repository

Update of /cvsroot/sbcl/sbcl/src/compiler/mips
In directory usw-pr-cvs1:/tmp/cvs-serv2957/src/compiler/mips

Log Message:
Directory /cvsroot/sbcl/sbcl/src/compiler/mips added to the repository

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory usw-pr-cvs1:/tmp/cvs-serv24066/src/compiler

Modified Files:
	fndb.lisp 
Log Message:
0.7.7.8:
	merged APD bug 122 patch (sbcl-devel 2002-08-30)
	Tweak seq.impure.lisp test more or less along the lines of
		APD's explanation of the pathname problem. (SUBSEQ is
		FLUSHABLE, and validly so. The old test bogusly relied
		on it not being flushed and/or the compiler not being
		infernally clever about type inference.)


Index: fndb.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- fndb.lisp	11 Jul 2002 02:15:05 -0000	1.38
+++ fndb.lisp	1 Sep 2002 21:49:02 -0000	1.39
@@ -1024,7 +1024,8 @@
 
 ;;; (No pathname functions are FOLDABLE because they all potentially
 ;;; depend on *DEFAULT-PATHNAME-DEFAULTS*, e.g. to provide a default
-;;; host when parsing a namestring.)
+;;; host when parsing a namestring. They are not FLUSHABLE because
+;;; parsing of a PATHNAME-DESIGNATOR might signal an error.)
 
 (defknown wild-pathname-p (pathname-designator
 			   &optional
@@ -1032,21 +1033,21 @@
 				   :directory :name
 				   :type :version))
   boolean
-  (flushable))
+  ())
 (defknown pathname-match-p (pathname-designator pathname-designator) boolean
-  (flushable))
+  ())
 (defknown translate-pathname (pathname-designator
 			      pathname-designator
 			      pathname-designator &key)
   pathname
-  (flushable))
+  ())
 
 (defknown logical-pathname (pathname-designator) logical-pathname ())
 (defknown translate-logical-pathname (pathname-designator &key) pathname ())
 (defknown load-logical-pathname-translations (string) t ())
 (defknown logical-pathname-translations (logical-host-designator) list ())
 
-(defknown pathname (pathname-designator) pathname (flushable))
+(defknown pathname (pathname-designator) pathname ())
 (defknown truename (pathname-designator) pathname ())
 
 (defknown parse-namestring
@@ -1063,7 +1064,7 @@
 (defknown merge-pathnames
   (pathname-designator &optional pathname-designator pathname-version)
   pathname
-  (flushable))
+  ())
 
 (defknown make-pathname
  (&key (:defaults pathname-designator)
@@ -1073,35 +1074,35 @@
        (:name (or pathname-name string (member :wild)))
        (:type (or pathname-type string (member :wild)))
        (:version pathname-version) (:case (member :local :common)))
-  pathname (flushable))
+  pathname ())
 
 (defknown pathnamep (t) boolean (movable flushable))
 
 (defknown pathname-host (pathname-designator
 			 &key (:case (member :local :common)))
-  pathname-host (flushable))
+  pathname-host ())
 (defknown pathname-device (pathname-designator
 			   &key (:case (member :local :common)))
-  pathname-device (flushable))
+  pathname-device ())
 (defknown pathname-directory (pathname-designator
 			      &key (:case (member :local :common)))
-  pathname-directory (flushable))
+  pathname-directory ())
 (defknown pathname-name (pathname-designator
 			 &key (:case (member :local :common)))
-  pathname-name (flushable))
+  pathname-name ())
 (defknown pathname-type (pathname-designator
 			 &key (:case (member :local :common)))
-  pathname-type (flushable))
+  pathname-type ())
 (defknown pathname-version (pathname-designator)
-  pathname-version (flushable))
+  pathname-version ())
 
 (defknown (namestring file-namestring directory-namestring host-namestring)
   (pathname-designator) simple-string
-  (flushable))
+  ())
 
 (defknown enough-namestring (pathname-designator &optional pathname-designator)
   simple-string
-  (flushable))
+  ())
 
 (defknown user-homedir-pathname (&optional t) pathname (flushable))
 
@@ -1119,11 +1120,11 @@
 (defknown rename-file (pathname-designator filename)
   (values pathname pathname pathname))
 (defknown delete-file (pathname-designator) t)
-(defknown probe-file (pathname-designator) (or pathname null) (flushable))
+(defknown probe-file (pathname-designator) (or pathname null) ())
 (defknown file-write-date (pathname-designator) (or unsigned-byte null)
-  (flushable))
+  ())
 (defknown file-author (pathname-designator) (or simple-string null)
-  (flushable))
+  ())
 
 (defknown file-position (stream &optional
 				(or unsigned-byte (member :start :end)))
@@ -1140,7 +1141,7 @@
   t)
 
 (defknown directory (pathname-designator &key)
-  list (flushable))
+  list ())
 
 ;;;; from the "Errors" chapter:

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv24066

Modified Files:
	version.lisp-expr 
Log Message:
0.7.7.8:
	merged APD bug 122 patch (sbcl-devel 2002-08-30)
	Tweak seq.impure.lisp test more or less along the lines of
		APD's explanation of the pathname problem. (SUBSEQ is
		FLUSHABLE, and validly so. The old test bogusly relied
		on it not being flushed and/or the compiler not being
		infernally clever about type inference.)


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.518
retrieving revision 1.519
diff -u -d -r1.518 -r1.519
--- version.lisp-expr	1 Sep 2002 15:14:04 -0000	1.518
+++ version.lisp-expr	1 Sep 2002 21:49:02 -0000	1.519
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.7.7"
+"0.7.7.8"

Update of /cvsroot/sbcl/sbcl/src/code
In directory usw-pr-cvs1:/tmp/cvs-serv24066/src/code

Modified Files:
	target-error.lisp 
Log Message:
0.7.7.8:
	merged APD bug 122 patch (sbcl-devel 2002-08-30)
	Tweak seq.impure.lisp test more or less along the lines of
		APD's explanation of the pathname problem. (SUBSEQ is
		FLUSHABLE, and validly so. The old test bogusly relied
		on it not being flushed and/or the compiler not being
		infernally clever about type inference.)


Index: target-error.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-error.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- target-error.lisp	13 Jan 2002 21:44:05 -0000	1.5
+++ target-error.lisp	1 Sep 2002 21:49:02 -0000	1.6
@@ -324,99 +324,18 @@
 
 ;;;; HANDLER-CASE
 
-(defmacro handler-case (form &rest clauses)
+(defmacro handler-case (form &rest cases)
   "(HANDLER-CASE form
    { (type ([var]) body) }* )
    Execute FORM in a context with handlers established for the condition
-   types. A peculiar property allows type to be :no-error. If such a clause
+   types. A peculiar property allows type to be :NO-ERROR. If such a clause
    occurs, and form returns normally, all its values are passed to this clause
    as if by MULTIPLE-VALUE-CALL.  The :NO-ERROR clause accepts more than one
    var specification."
 
-  ;; FIXME: This old SBCL code uses multiple nested THROW/CATCH
-  ;; operations, which seems like an ugly way to handle lexical
-  ;; nonlocal exit. MNA sbcl-devel 2001-07-17 provided a patch
-  ;; (included below this form, but #+NIL'ed out) to switch over to
-  ;; RETURN-FROM, which seems like basically a better idea.
-  ;; Unfortunately when using his patch, this reasonable code
-  ;;	(DEFUN FOO1I ()
-  ;;	  (IF (NOT (IGNORE-ERRORS
-  ;;		     (MAKE-PATHNAME :HOST "FOO"
-  ;;				    :DIRECTORY "!BLA"
-  ;;				    :NAME "BAR")))
-  ;;	      (PRINT "OK")
-  ;;	      (ERROR "NOTUNLESSNOT")))
-  ;; fails (doing ERROR "NOTUNLESSNOT" when it should PRINT "OK"
-  ;; instead). I think this may not be a bug in MNA's patch, but 
-  ;; instead in the rest of the compiler (e.g. handling of RETURN-FROM)
-  ;; but whatever the reason. (I noticed this problem in
-  ;; sbcl-0.pre7.14.flaky4.11, and reverted to the old code at that point.
-  ;; The problem also occurs at least in sbcl-0.6.12.59 and
-  ;; sbcl-0.6.13.) -- WHN
-  ;;
-  ;; Note also: I think the old nested THROW/CATCH version became
-  ;; easier to read once I converted it to use DESTRUCTURING-BIND and
-  ;; mnemonic names, and it would probably be a useful to do that to
-  ;; the RETURN-FROM version when/if it's adopted.
-  (let ((no-error-clause (assoc ':no-error clauses)))
-    (if no-error-clause
-        (let ((normal-return (make-symbol "normal-return"))
-              (error-return  (make-symbol "error-return")))
-          `(block ,error-return
-             (multiple-value-call #'(lambda ,@(cdr no-error-clause))
-               (block ,normal-return
-                 (return-from ,error-return
-                   (handler-case (return-from ,normal-return ,form)
-		     ;; FIXME: What if there's more than one :NO-ERROR
-		     ;; clause? The code here and above doesn't seem
-		     ;; either to remove both of them or to signal
-		     ;; a good error, so it's probably wrong.
-                     ,@(remove no-error-clause clauses)))))))
-        (let ((var (gensym "HC-VAR-"))
-              (outer-tag (gensym "OUTER-HC-TAG-"))
-              (inner-tag (gensym "INNER-HC-TAG-"))
-              (tag-var (gensym "HC-TAG-VAR-"))
-              (tagged-clauses (mapcar (lambda (clause)
-					(cons (gensym "HC-TAG-") clause))
-				      clauses)))
-          `(let ((,outer-tag (cons nil nil))
-                 (,inner-tag (cons nil nil))
-                 ,var ,tag-var)
-             ;; FIXME: should be (DECLARE (IGNORABLE ,VAR))
-             ,var                       ;ignoreable
-             (catch ,outer-tag
-               (catch ,inner-tag
-                 (throw ,outer-tag
-                        (handler-bind
-                            ,(mapcar (lambda (tagged-clause)
-				       (destructuring-bind
-					   (tag typespec args &body body)
-					   tagged-clause
-					 (declare (ignore body))
-                                         `(,typespec
-                                           (lambda (temp)
-					     ,(if args
-						  `(setq ,var temp)
-						  '(declare (ignore temp)))
-					     (setf ,tag-var ',tag)
-					     (/show "THROWing INNER-TAG from HANDLER-BIND closure for" ',typespec)
-					     (throw ,inner-tag nil)))))
-                                     tagged-clauses)
-                          ,form)))
-               (case ,tag-var
-                 ,@(mapcar (lambda (tagged-clause)
-			     (destructuring-bind
-				 (tag typespec args &body body)
-				 tagged-clause
-			       (declare (ignore typespec))
-			       `(,tag
-				 ,@(if args
-				       (destructuring-bind (arg) args
-					 `((let ((,arg ,var))
-					     ,@body)))
-				       body))))
-                           tagged-clauses)))))))
-  #+nil ; MNA's patched version -- see FIXME above
+  ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND
+  ;; and names for the subexpressions would make it easier to
+  ;; understand the code below.
   (let ((no-error-clause (assoc ':no-error cases)))
     (if no-error-clause
 	(let ((normal-return (make-symbol "normal-return"))

Update of /cvsroot/sbcl/sbcl/tests
In directory usw-pr-cvs1:/tmp/cvs-serv24066/tests

Modified Files:
	seq.impure.lisp 
Log Message:
0.7.7.8:
	merged APD bug 122 patch (sbcl-devel 2002-08-30)
	Tweak seq.impure.lisp test more or less along the lines of
		APD's explanation of the pathname problem. (SUBSEQ is
		FLUSHABLE, and validly so. The old test bogusly relied
		on it not being flushed and/or the compiler not being
		infernally clever about type inference.)


Index: seq.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/seq.impure.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- seq.impure.lisp	5 Jul 2002 14:39:51 -0000	1.6
+++ seq.impure.lisp	1 Sep 2002 21:49:02 -0000	1.7
@@ -196,7 +196,7 @@
   ;; physical ARRAY-DIMENSION 0.
   ;;
   ;; fixed in sbcl-0.7.4.22 by WHN
-  (assert (null (ignore-errors (subseq avec 1 5)))))
+  (assert (null (ignore-errors (aref (subseq avec 1 5) 0)))))
 
 ;;; FILL
 (defun test-fill-typecheck (x)

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory usw-pr-cvs1:/tmp/cvs-serv9163/src/runtime

Modified Files:
	Config.sparc-sunos 
Log Message:
0.7.7.7:
	HPPA (CATCH 0 ...) fix
	sbcl.nm SPARC/Sunos fix (thanks to Antonio Martinez, sbcl-devel
		2002-08-23)
	filesys.test.sh symlinks and NFS fix (Eric Marsden sbcl-devel 
		2002-08-23)


Index: Config.sparc-sunos
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/Config.sparc-sunos,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- Config.sparc-sunos	6 Aug 2002 11:46:32 -0000	1.2
+++ Config.sparc-sunos	1 Sep 2002 15:14:05 -0000	1.3
@@ -13,7 +13,7 @@
 ASFLAGS = -g -Wall -Dsparc -DSVR4
 LD = ld 
 LINKFLAGS = -v -g 
-NM = nm -p
+NM = nm -t x -p 
 
 ASSEM_SRC = sparc-assem.S 
 #ARCH_SRC = sparc-arch.c undefineds.c

Update of /cvsroot/sbcl/sbcl/tests
In directory usw-pr-cvs1:/tmp/cvs-serv9163/tests

Modified Files:
	filesys.test.sh 
Log Message:
0.7.7.7:
	HPPA (CATCH 0 ...) fix
	sbcl.nm SPARC/Sunos fix (thanks to Antonio Martinez, sbcl-devel
		2002-08-23)
	filesys.test.sh symlinks and NFS fix (Eric Marsden sbcl-devel 
		2002-08-23)


Index: filesys.test.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/filesys.test.sh,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- filesys.test.sh	12 Jun 2002 11:51:56 -0000	1.6
+++ filesys.test.sh	1 Sep 2002 15:14:05 -0000	1.7
@@ -12,7 +12,7 @@
 # more information.
 
 # Test DIRECTORY and TRUENAME.
-testdir=`pwd`"/filesys-test-$$"
+testdir=`/bin/pwd`"/filesys-test-$$"
 mkdir $testdir
 echo this is a test > $testdir/test-1.tmp
 echo this is a test > $testdir/test-2.tmp

Update of /cvsroot/sbcl/sbcl/src/compiler/hppa
In directory usw-pr-cvs1:/tmp/cvs-serv9163/src/compiler/hppa

Modified Files:
	nlx.lisp 
Log Message:
0.7.7.7:
	HPPA (CATCH 0 ...) fix
	sbcl.nm SPARC/Sunos fix (thanks to Antonio Martinez, sbcl-devel
		2002-08-23)
	filesys.test.sh symlinks and NFS fix (Eric Marsden sbcl-devel 
		2002-08-23)


Index: nlx.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/hppa/nlx.lisp,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- nlx.lisp	19 Aug 2002 12:14:01 -0000	1.1
+++ nlx.lisp	1 Sep 2002 15:14:05 -0000	1.2
@@ -96,7 +96,7 @@
 ;;;
 (define-vop (make-catch-block)
   (:args (tn)
-	 (tag :scs (descriptor-reg)))
+	 (tag :scs (any-reg descriptor-reg)))
   (:info entry-label)
   (:results (block :scs (any-reg) :from (:argument 0)))
   (:temporary (:scs (descriptor-reg)) temp)

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv9163

Modified Files:
	version.lisp-expr 
Log Message:
0.7.7.7:
	HPPA (CATCH 0 ...) fix
	sbcl.nm SPARC/Sunos fix (thanks to Antonio Martinez, sbcl-devel
		2002-08-23)
	filesys.test.sh symlinks and NFS fix (Eric Marsden sbcl-devel 
		2002-08-23)


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.517
retrieving revision 1.518
diff -u -d -r1.517 -r1.518
--- version.lisp-expr	31 Aug 2002 23:36:57 -0000	1.517
+++ version.lisp-expr	1 Sep 2002 15:14:04 -0000	1.518
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.7.6"
+"0.7.7.7"