Commit 8b81ecb0 authored by chiles's avatar chiles
Browse files

Initial revision

parent b39dbd80
;;; -*- Package: RT -*-
;;;
;;; **********************************************************************
;;; 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/assembly/rt/alloc.lisp,v 1.1 1991/02/18 15:43:28 chiles Exp $
;;;
;;; Stuff to handle allocating simple objects.
;;;
;;; Written by William Lott.
;;; Converted to the IBM RT by Bill Chiles.
;;;
(in-package "RT")
(define-for-each-primitive-object (obj)
(let* ((options (primitive-object-options obj))
(alloc-trans (getf options :alloc-trans))
(alloc-vop (getf options :alloc-vop alloc-trans))
(header (primitive-object-header obj))
(lowtag (primitive-object-lowtag obj))
(size (primitive-object-size obj))
(variable-length (primitive-object-variable-length obj))
(need-unbound-marker nil))
(collect ((args) (init-forms))
(when (and alloc-vop variable-length)
(args 'extra-words))
(dolist (slot (primitive-object-slots obj))
(let* ((name (slot-name slot))
(offset (slot-offset slot)))
(ecase (getf (slot-options slot) :init :zero)
(:zero)
(:null
(init-forms `(storew null-tn result ,offset ,lowtag)))
(:unbound
(setf need-unbound-marker t)
(init-forms `(storew temp result ,offset ,lowtag)))
(:arg
(args name)
(init-forms `(storew ,name result ,offset ,lowtag))))))
(when (and (null alloc-vop) (args))
(error "Slots ~S want to be initialized, but there is no alloc vop ~
defined for ~S."
(args) (primitive-object-name obj)))
(when alloc-vop
`(define-assembly-routine
(,alloc-vop
(:cost 35)
,@(when alloc-trans
`((:translate ,alloc-trans)))
(:policy :fast-safe))
(,@(let ((arg-offsets (cdr register-arg-offsets)))
(mapcar #'(lambda (name)
(unless arg-offsets
(error "Too many args in ~S" alloc-vop))
`(:arg ,name (descriptor-reg any-reg)
,(pop arg-offsets)))
(args)))
(:temp alloc non-descriptor-reg nl0-offset)
,@(when (or need-unbound-marker header variable-length)
'((:temp temp non-descriptor-reg ocfp-offset)))
(:res result descriptor-reg a0-offset))
(pseudo-atomic (alloc)
(load-symbol-value alloc *allocation-pointer*)
(inst cal result alloc ,lowtag)
,@(cond ((and header variable-length)
`((inst cal temp extra-words (fixnum (1- ,size)))
(inst cas alloc temp alloc)
(inst sl temp (- type-bits word-shift))
(inst oil temp ,header)
(storew temp result 0 ,lowtag)
(inst cal alloc (+ (fixnum 1) lowtag-mask))
(inst li temp (lognot lowtag-mask))
(inst n alloc temp)))
(variable-length
(error ":REST-P T with no header in ~S?"
(primitive-object-name obj)))
(header
`((inst cal alloc (pad-data-block ,size))
(inst li temp
,(logior (ash (1- size) type-bits)
(symbol-value header)))
(storew temp result 0 ,lowtag)))
(t
`((inst cal alloc (pad-data-block ,size)))))
,@(when need-unbound-marker
`((inst li temp unbound-marker-type)))
,@(init-forms)))))))
;;; -*- Package: RT -*-
;;;
;;; **********************************************************************
;;; 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/rt/arith.lisp,v 1.1 1991/02/18 15:43:31 chiles Exp $
;;;
;;; Stuff to handle simple cases for generic arithmetic.
;;;
;;; Written by William Lott.
;;; Converted to IBM RT by Bill Chiles.
(in-package "RT")
(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 lip interior-reg lip-offset)
(:temp lra descriptor-reg lra-offset)
(:temp nargs any-reg nargs-offset)
(:temp cname descriptor-reg cname-offset)
(:temp ocfp any-reg ocfp-offset))
;; If either arg is not a fixnum, call the static function.
(inst n temp x 3)
(inst bnc :eq DO-STATIC-FUN)
(inst n temp y 3)
(inst bnc :eq DO-STATIC-FUN)
;; Use ocfp as a temporary result.
(move ocfp x)
(inst a ocfp y)
(inst bnc :ov fixnum-result)
;; If we overflowed, shift the operands down to lose the fixnum lowtag bits
;; and do the add again.
(move ocfp x)
(inst sar ocfp 2)
(move temp y)
(inst sar temp 2)
(inst a ocfp temp)
;; Allocate a bignum for sum.
(with-fixed-allocation (res temp cname bignum-type
(1+ bignum-digits-offset))
(storew ocfp res bignum-digits-offset other-pointer-type))
;; Now get out of here.
(lisp-return lra lip :offset 2)
DO-STATIC-FUN
(load-symbol cname 'two-arg-+)
(inst li nargs (fixnum 2))
(loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
(move ocfp cfp-tn)
;; Tail call TWO-ARG-+.
(inst bx lip)
(move cfp-tn csp-tn)
FIXNUM-RESULT
;; Ocfp was used for the temporary result.
(move res ocfp))
(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 lip interior-reg lip-offset)
(:temp lra descriptor-reg lra-offset)
(:temp nargs any-reg nargs-offset)
(:temp cname descriptor-reg cname-offset)
(:temp ocfp any-reg ocfp-offset))
;; If either arg is not a fixnum, call the static function.
(inst n temp x 3)
(inst bnc :eq DO-STATIC-FUN)
(inst n temp y 3)
(inst bnc :eq DO-STATIC-FUN)
;; Use ocfp as a temporary result.
(move ocfp x)
(inst s ocfp y)
(inst bnc :ov fixnum-result)
;; If we overflowed, shift the operands down to lose the fixnum lowtag bits
;; and do the subtract again.
(move ocfp x)
(inst sar ocfp 2)
(move temp y)
(inst sar temp 2)
(inst s ocfp temp)
;; Allocate a bignum for sum.
(with-fixed-allocation (res temp cname bignum-type
(1+ bignum-digits-offset))
(storew ocfp res bignum-digits-offset other-pointer-type))
;; Now get out of here.
(lisp-return lra lip :offset 2)
DO-STATIC-FUN
(load-symbol cname 'two-arg--)
(inst li nargs (fixnum 2))
(loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
(move ocfp cfp-tn)
;; Tail call TWO-ARG-+.
(inst bx lip)
(move cfp-tn csp-tn)
FIXNUM-RESULT
;; Ocfp was used for the temporary result.
(move res ocfp))
(define-assembly-routine (generic-*
(:cost 70)
(: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 alloc word-pointer-reg a2-offset)
(:temp lip interior-reg lip-offset)
(:temp lra descriptor-reg lra-offset)
(:temp nargs/high non-descriptor-reg nargs-offset)
(:temp ocfp/low non-descriptor-reg ocfp-offset)
(:temp cname descriptor-reg cname-offset))
;; If either arg is not a fixnum, call the static function.
(inst n temp x 3)
(inst bnc :eq DO-STATIC-FUN)
(inst n temp y 3)
(inst bnc :eq DO-STATIC-FUN)
;; Remove the tag from one arg so that the result will have the correct
;; fixnum lowtag. Without this, the result if off by a factor of 16, but we
;; want it off by a factor of 4 (the fixnum lowtag).
(move temp x)
(inst sr temp 2)
;; Setup system register for multiply.
(inst mtmqscr temp)
;; Do the multiply.
;; Subtract high from high to set it to zero and to set the C0 condition
;; bit appropriately for the m instruction.
(inst s nargs/high nargs/high)
(dotimes (i 15)
(inst m nargs/high y))
(inst mfmqscr res)
;; 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).
(move temp res)
(inst sar temp 31)
(inst c temp nargs/high)
(inst bc :eq DONE)
;; Build two bignum-digits by shifting the double word high:res down two bits
;; into high:low to get rid of the fixnum lowtag.
(move ocfp/low res)
(inst sr ocfp/low 2)
(move temp nargs/high)
(inst sl temp 30)
(inst o ocfp/low temp)
(inst sar nargs/high 2)
;; Allocate a bignum for the result.
(pseudo-atomic (temp)
(let ((one-word (gen-label)))
(load-symbol-value alloc *allocation-pointer*)
(inst cal res alloc other-pointer-type)
;; Assume we need one word.
(inst cal alloc (pad-data-block (1+ bignum-digits-offset)))
;; Is that correct?
(inst sar temp ocfp/low 31)
(inst c temp nargs/high)
(inst bcx :eq one-word)
(inst li temp (logior (ash 1 type-bits) bignum-type))
;; Nope, we need two, so allocate the addition space.
(inst cal alloc (- (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 nargs/high res (1+ bignum-digits-offset) other-pointer-type)
(emit-label one-word)
(storew alloc *allocation-pointer*)
(storew temp res 0 other-pointer-type)
(storew ocfp/low res bignum-digits-offset other-pointer-type)))
;; Out of here
(lisp-return lra lip :offset 2)
DO-STATIC-FUN
(load-symbol cname 'two-arg-*)
(inst li nargs/high (fixnum 2))
(loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
(move ocfp/low cfp-tn)
(inst bx lip)
(move cfp-tn csp-tn)
DONE)
(define-assembly-routine (generic-truncate
(:cost 95)
(:return-style :full-call)
(:translate truncate)
(:policy :safe)
(:save-p t))
((:arg x (descriptor-reg any-reg) a0-offset)
(:arg y (descriptor-reg any-reg) a1-offset)
(:res quo (descriptor-reg any-reg) a0-offset)
(:res rem (descriptor-reg any-reg) a1-offset)
(:temp temp1 non-descriptor-reg nl0-offset)
(:temp alloc word-pointer-reg a2-offset)
(:temp lip interior-reg lip-offset)
(:temp lra descriptor-reg lra-offset)
;; High holds the sign of x and becomes the remainder.
(:temp nargs/high non-descriptor-reg nargs-offset)
(:temp cname descriptor-reg cname-offset)
(:temp ocfp/temp2 non-descriptor-reg ocfp-offset))
;; If either arg is not a fixnum, call the static function.
(inst n temp1 x 3)
(inst bnc :eq DO-STATIC-FUN)
(inst n temp1 y 3)
(inst bnc :eq DO-STATIC-FUN)
;; Make sure y is not 0, 1, or -1.
(inst c y 0)
(inst bcx :eq zero-divisor)
(inst c y (fixnum 1))
(inst bcx :eq one-divisor)
(inst c y (fixnum -1))
(inst bc :eq neg-one-divisor)
;; Do the division.
(move nargs/high x)
(inst sar nargs/high 31)
(inst mtmqscr x)
(dotimes (i 32)
(inst d nargs/high y))
;; Check preliminary remainder by considering signs of high and y.
;; This is an extra step to account for the non-restoring divide-step instr.
;; We don't actually have to check this since the d instruction set :c0
;; when the signs of high and y are the same.
(inst bc :c0 rem-okay)
(inst a nargs/high y)
REM-OKAY
;; The RT gives us a Common Lisp FLOOR, but we're writing TRUNCATE.
;; The fixup involves adding one to the quotient and subtracting the divisor
;; from the remainder whenever the divisor and dividend had differing signs.
;; Of course, don't diddle anything when the remainder is zero.
(inst c nargs/high 0)
(inst bc :eq move-results)
(move temp1 x)
(inst xor temp1 y)
(inst bnc :lt move-results)
;; Add 1 to quotient and subtract divisor from remainder.
(inst mfmqscr temp1)
(inst sl temp1 2)
(inst a quo temp1 (fixnum 1))
;; Since rem and y are the same register, this subtracts the divisor from
;; the remainder, putting the result in our rem result register.
(inst sf y nargs/high)
(inst b done)
MOVE-RESULTS
(inst mfmqscr temp1)
(inst sl temp1 2)
(move quo temp1)
;; The remainder is always on the same order of magnitude as the dividend,
;; so it already has fixnum lowtag bits.
(move rem nargs/high)
(inst b done)
DO-STATIC-FUN
(load-symbol cname 'two-arg-truncate)
(inst li nargs/high (fixnum 2))
(loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
(move ocfp/temp2 cfp-tn)
;; Get out of here, doing a tail call.
(inst bx lip)
(move cfp-tn csp-tn)
ZERO-DIVISOR
;; signal an error somehow.
NEG-ONE-DIVISOR
(li rem 0)
(inst neg quo x)
;; If quo still fits in a fixnum, go to done.
(inst bnc :ov done)
;; Allocate a bignum for quo.
(with-fixed-allocation (temp1 ocfp/temp2 alloc bignum-type
(+ 2 bignum-digits-offset))
;; If we overflowed quo, then we must have made a positive value from a
;; negative one. The overflow would be one bit and some zero's for sign.
(inst li ocfp/temp2 0)
(storew quo temp1 bignum-digits-offset other-pointer-type)
(storew ocfp/temp2 temp1 (1+ bignum-digits-offset) other-pointer-type))
(move quo temp1)
(inst b done)
ONE-DIVISOR
(li rem 0)
(move quo x)
DONE)
;;; -*- Package: RT -*-
;;;
;;; **********************************************************************
;;; 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/assembly/rt/array.lisp,v 1.1 1991/02/18 15:43:32 chiles Exp $
;;;
;;; This file contains the support routines for arrays and vectors.
;;;
;;; Written by William Lott.
;;;
(in-package "RT")
(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 alloc word-pointer-reg ocfp-offset)
(:temp vector descriptor-reg cname-offset))
(pseudo-atomic (ndescr)
(load-symbol-value alloc *allocation-pointer*)
(inst cal vector alloc vm:other-pointer-type)
(inst cal alloc alloc (+ (1- (ash 1 vm:lowtag-bits))
(* vm:vector-data-offset vm:word-bytes)))
(inst cal alloc alloc words)
(inst li ndescr (lognot vm:lowtag-mask))
(inst n alloc ndescr)
(move ndescr type)
(inst sr ndescr 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
(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 nargs-offset)
(:temp temp non-descriptor-reg ocfp-offset))
(declare (ignore result accum data temp offset))
(inst b sxhash-simple-substring-entry)
(loadw length string vm:vector-length-slot vm:other-pointer-type))
(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 nargs-offset)
(:temp temp non-descriptor-reg ocfp-offset)
(:temp lip interior-reg lip-offset))
(emit-label sxhash-simple-substring-entry)
;; Get a stack slot and save the contents of NFP.
(inst inc csp-tn word-bytes)
(storew nfp-tn csp-tn (* -1 word-bytes))
;; Save the return-pc in NFP as a byte offset from the component start.
(move nfp-tn lip)
(inst s nfp-tn code-tn)
(inst a lip string (- (* vector-data-offset word-bytes) other-pointer-type))
(inst b test)
(inst li accum 0)
LOOP
(inst x accum data)
(move temp accum)
(inst sl temp 27)
(inst sr accum 5)
(inst o accum temp)
(inst inc lip 4)
TEST
(inst s length (fixnum 4))
(inst bnc :lt loop)
(loadw data lip)
(inst a length (fixnum 4))
(inst bc :eq done)
(inst neg length)
(inst sl length 1)
(inst sr data length)
(inst x accum data)
DONE
(inst sl result accum 5)
(inst sr result result 3)
(move code-tn lip)
(inst a lip nfp-tn)
(loadw nft-tn csp-tn (* -1 word-bytes))
(inst dec csp-tn word-bytes))
;;; -*- Package: RT; Log: c.log -*-
;;;
;;; **********************************************************************
;;; 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/assembly/rt/assem-rtns.lisp,v 1.1 1991/02/18 15:43:33 chiles Exp $
;;;
(in-package "RT")
;;;; Non-local exit noise.
(define-assembly-routine (unwind (:translate %continue-unwind)
(:policy :fast-safe))
((:arg block (word-pointer-reg any-reg descriptor-reg)
a0-offset)
(:arg start (word-pointer-reg 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 cname-offset)
(:temp target-uwp any-reg lexenv-offset))
(declare (ignore start count))
(let ((error (generate-error-code nil invalid-unwind-error)))
(inst c block 0)
(inst b :eq error))
(load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
(loadw target-uwp block unwind-block-current-uwp-slot)
(inst c cur-uwp target-uwp)
(inst bnc :eq do-uwp)
(move cur-uwp block)
DO-EXIT
(loadw fp-tn cur-uwp unwind-block-current-cont-slot)
(loadw code-tn cur-uwp unwind-block-current-code-slot)
(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 bx do-exit)
(store-symbol-value next-uwp lisp::*current-unwind-protect-block*))
(define-assembly-routine throw
((:arg target descriptor-reg a0-offset)
(:arg start word-pointer-reg ocfp-offset)
(:arg count any-reg nargs-offset)
(:temp catch any-reg a1-offset)
(:temp tag descriptor-reg a2-offset)
(:temp ndescr non-descriptor-reg nl0-offset))
(load-symbol-value catch lisp::*current-catch-block*)
LOOP
(let ((error (generate-error-code nil unseen-throw-tag-error target)))
(inst c catch 0)
(inst bc :eq error))
(loadw tag catch catch-block-tag-slot)
(inst c tag target)
(inst bc :eq exit)
(loadw catch catch catch-block-previous-catch-slot)
(inst b loop)
EXIT