diff --git a/assembly/rt/alloc.lisp b/assembly/rt/alloc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..7d444709722a1c4807718bf688dabfc80b548cea --- /dev/null +++ b/assembly/rt/alloc.lisp @@ -0,0 +1,93 @@ +;;; -*- 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))))))) diff --git a/assembly/rt/arith.lisp b/assembly/rt/arith.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6315420d25a3e3939b47574e6a84fbf498cd9425 --- /dev/null +++ b/assembly/rt/arith.lisp @@ -0,0 +1,324 @@ +;;; -*- 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) diff --git a/assembly/rt/array.lisp b/assembly/rt/array.lisp new file mode 100644 index 0000000000000000000000000000000000000000..05643241e09eb7377e02f6f4f9fa8e261fca0dae --- /dev/null +++ b/assembly/rt/array.lisp @@ -0,0 +1,114 @@ +;;; -*- 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)) diff --git a/assembly/rt/assem-rtns.lisp b/assembly/rt/assem-rtns.lisp new file mode 100644 index 0000000000000000000000000000000000000000..9a41138e694f6907a380455f2b2f134aa83c5884 --- /dev/null +++ b/assembly/rt/assem-rtns.lisp @@ -0,0 +1,296 @@ +;;; -*- 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 + + (move target catch) + (inst cai ndescr (make-fixup 'unwind :assembly-routine)) + (inst b ndescr)) + + + +;;;; Return unknown multiple values (known not to be one value). + +(define-assembly-routine really-return-multiple + ((:arg ocfp any-reg nl0-offset) + (:arg lra descriptor-reg lra-offset) + ;; Pointer into cstack, so looks like fixnum. + (:arg src any-reg cname-offset) + (:arg nvals any-reg nargs-offset) + + (:temp count any-reg ocfp-offset) + ;; Pointer into cstack, so looks like fixnum. + (:temp dst any-reg lexenv-offset) + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset)) + ;; + ;; Load the register args, bailing out when we are done. + (inst c nvals 0) + (inst bc :eq default-a0-and-on) + (loadw a0 src 0) + (inst c nvals 1) + (inst bc :eq default-a1-and-on) + (loadw a1 src 1) + (inst c nvals 2) + (inst bc :eq default-a2-and-on) + (loadw a2 src 2) + ;; + ;; Copy the remaining args to the top of the stack. + (inst inc src (* word-bytes register-arg-count)) + (inst cal dst fp-tn (* word-bytes register-arg-count)) + (inst s count nvals (fixnum 3)) + (inst bnc :gt done) + LOOP + (loadw temp src) + (inst inc src word-bytes) + (storew temp dst) + (inst inc dst word-bytes) + (inst s count (fixnum 1)) + (inst bc :gt loop) + (inst b done) + ;; + ;; Default some number of registers. + DEFAULT-A0-AND-ON + (move a0 null-tn) + DEFAULT-A1-AND-ON + (move a1 null-tn) + DEFAULT-A2-AND-ON + (move a2 null-tn) + ;; + ;; Clear the stack. + DONE + (move count cfp-tn) ;Put pointer to the start of values in ocfp. + (inst cas csp-tn nargs count) ;Adjust the stack top: <ptr-to-vals>+<nvals>. + (move fp-tn ocfp) ;Restore returnee's fp. + ;; + ;; Return. + (lisp-return lra lip)) + + + +;;;; Copying more args on call (known to be at least one more arg.) + +;;; REALLY-COPY-MORE-ARGS -- Assembler Routine. +;;; +;;; This miscop has weird register usage conventions, since it is called at the +;;; very beginning of entry to a more-arg XEP. All of the registers used +;;; by the full call convention are in use, and must not be trashed, but none +;;; of the normal local & temporary registers are in use, since we haven't done +;;; anything yet. The number of fixed arguments is passed in a3, since we +;;; can't trash a0..a2. +;;; +;;; The VOP COPY-MORE-ARG has allocated some temporaries for us: a3, l0, l1. + +;;; The registers we can use are NL1, A3, L0 and L1. We save L2 and L3 to give +;;; us some more registers to work with. The caller saves the function return +;;; PC in L2 (the now unused NAME) so that it can be used for the miscop return +;;; PC. +;;; +;;; What we do is fairly simple: we copy the incoming more arguments (index >= +;;; a3) onto the top of the stack. The loop runs backwards, since we are +;;; copying args upward on the stack, and the source and destination can +;;; overlap. +;;; +;;; This loop terminates when we either run out of more args to copy or we run +;;; out of stack arguments. If we run out of stack arguments before we finish, +;;; then there are register more args. In this case, we dispatch off of the +;;; number of fixed arguments (A3) to determine how many argument registers to +;;; store. +;;; +(define-assembly-routine really-copy-more-args + ;; Fixedargs contains the number of fixed arguments. + ((:arg fixedargs any-reg cname-offset) + (:temp count/src any-reg nfp-offset) + (:temp ocsp any-reg nl0-offset) + ;; Temporaries to get my hands on argument registers. + (:temp a0 any-reg a0-offset) + (:temp a1 any-reg a1-offset) + (:temp a2 any-reg a2-offset) + ;; We save the contents of these registers before + ;; using them. + (:temp srcstart any-reg lexenv-offset) + (:temp dstend any-reg lra-offset) + (:temp temp any-reg ocfp-offset)) + ;; How many more args are there to copy to the stack? + (move count/src nargs-tn) + (inst s count/src fixedargs) + ;; Save the current stack top as the start of the more args. + (move ocsp csp-tn) + ;; Bump the stack by the number of more args. + (inst cas csp-tn csp-tn count/src) + ;; Bump the stack three for the registers we have to save. + (inst cal csp-tn csp-tn (* 3 word-bytes)) + + ;; Dump the registers to make room for the temporaries we need. + (storew srcstart csp-tn -3) + (storew dstend csp-tn -2) + (storew temp csp-tn -1) + + ;; Compute the source start, but remember we are copying from the end. + ;; The start location is the last one we copy. + (inst cal srcstart cfp-tn (* register-arg-count word-bytes)) + ;; Compute the source location of the last more arg. + (inst cal count/src cfp-tn nargs-tn) + (inst dec count/src word-bytes) ;not an exclusive end. + ;; Compute destination end, which is the stack pointer minus three register + ;; slots we saved and minus one to make it an inclusive end. + (inst cal dstend csp-tn (* -4 word-bytes)) + + ;; Copy some args. + (inst b cma-test) + CMA-LOOP + (loadw temp count/src) + (storew temp dstend) + (inst dec count/src word-bytes) + (inst dec dstend word-bytes) + CMA-TEST + ;; Are we totally done? + (inst c dstend ocsp) + (inst bc :lt CMA-DONE) + ;; Are we done copying stack more args? + (inst c count/src srcstart) + (inst bnc :lt CMA-LOOP) + + ;; Figure out which argument registers may be more args. + (inst c fixedargs (fixnum 2)) + (inst bc :eq two-fixed-args) + (inst c fixedargs (fixnum 1)) + (inst bc :eq one-fixed-arg) + + ;; Copy register more args being careful to stop before running out of args. + (storew a0 ocsp) + (inst c nargs-tn (fixnum 1)) + (inst bc :eq CMA-DONE) + (inst inc ocsp word-bytes) + ONE-FIXED-ARG + (storew a1 ocsp) + (inst c nargs-tn (fixnum 2)) + (inst bc :eq CMA-DONE) + (inst inc ocsp word-bytes) + TWO-FIXED-ARGS + (storew a2 ocsp) + + ;; Restore registers we dumped. + CMA-DONE + (loadw srcstart csp-tn -3) + (loadw dstend csp-tn -2) + (loadw temp csp-tn -1) + (inst b lip-tn)) + + + +;;;; Tail call variable. + +(define-assembly-routine (really-tail-call-variable (:return-style :none)) + ;; These are really args. + ((:temp args any-reg nl0-offset) + ;; These are needed by the blitting code. + (:temp nargs/src any-reg nargs-offset) + (:temp lexenv/dst any-reg lexenv-offset) + (:temp count any-reg lra-offset) + (:temp temp descriptor-reg cname-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)) + ;; Calculate NARGS (as a fixnum). + (move nargs/src csp-tn) + (inst s nargs/src args) + ;; Load the argument registers now because the argument moving might trash + ;; these locations. + (loadw a0 args (* 0 vm:word-bytes)) + (loadw a1 args (* 1 vm:word-bytes)) + (loadw a2 args (* 2 vm:word-bytes)) + ;; Calc SRC, DST, and COUNT. + (inst a count nargs/src (fixnum (- register-arg-count))) + (inst bnc :gt done) + (inst a nargs/src args (* vm:word-bytes register-arg-count)) + (inst a lexenv/dst cfp-tn (* vm:word-bytes register-arg-count)) + LOOP + ;; Copy one arg. + (loadw temp nargs/src) + (inst a nargs/src vm:word-bytes) + (storew temp lexenv/dst) + (inst a count (fixnum -1)) + (inst bc :gt loop) + (inst a lexenv/dst vm:word-bytes) + DONE + ;; We are done. Do the jump. + (loadw temp lexenv/dst vm:closure-function-slot vm:function-pointer-type) + (lisp-jump temp lip-tn)) diff --git a/assembly/rt/support.lisp b/assembly/rt/support.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a414c84d6b82457ee6c03fb90ddd626aefc1ec3e --- /dev/null +++ b/assembly/rt/support.lisp @@ -0,0 +1,61 @@ +;;; -*- 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/support.lisp,v 1.1 1991/02/18 15:43:35 chiles Exp $ +;;; +;;; This file contains the machine specific support routines needed by +;;; the file assembler. +;;; + +(in-package "RT") + +(def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + (:raw + (values + `((inst bala (make-fixup ',name :assembly-routine))) + nil)) + (:full-call + (let ((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 cur-nfp ,nfp-save)) + (inst compute-lra-from-code ,lra code-tn lra-label) + ;; This absolute branch trashes the LIP register, but we don't use + ;; it when calling assembly routines. + (inst bala (make-fixup ',name :assembly-routine)) + (emit-return-pc lra-label) + (note-this-location ,vop :unknown-return) + (move csp-tn ocfp-tn) + (inst compute-code-from-lra code-tn code-tn lra-label) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save))))) + (:none + (values + ;; This absolute branch trashes the LIP register, but we don't use it + ;; when calling assembly routines. + `((inst bala (make-fixup ',name :assembly-routine))) + nil)))) + + +(def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `((inst b lip-tn))) + (:full-call + `((lisp-return lra-tn lip-tn :offset 2))) + (:none)))