From 367fcfdf16bd50e67eb01cd9157b897560b502ec Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Thu, 22 Nov 1990 11:51:46 +0000 Subject: [PATCH] Initial revision --- assembly/sparc/alloc.lisp | 89 ++++++++++ assembly/sparc/arith.lisp | 286 +++++++++++++++++++++++++++++++++ assembly/sparc/array.lisp | 171 ++++++++++++++++++++ assembly/sparc/assem-rtns.lisp | 242 ++++++++++++++++++++++++++++ assembly/sparc/support.lisp | 79 +++++++++ 5 files changed, 867 insertions(+) create mode 100644 assembly/sparc/alloc.lisp create mode 100644 assembly/sparc/arith.lisp create mode 100644 assembly/sparc/array.lisp create mode 100644 assembly/sparc/assem-rtns.lisp create mode 100644 assembly/sparc/support.lisp diff --git a/assembly/sparc/alloc.lisp b/assembly/sparc/alloc.lisp new file mode 100644 index 000000000..d728770d0 --- /dev/null +++ b/assembly/sparc/alloc.lisp @@ -0,0 +1,89 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; 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/sparc/alloc.lisp,v 1.1 1990/11/22 11:49:39 wlott Exp $ +;;; +;;; Stuff to handle allocating simple objects. +;;; +;;; Written by William Lott. +;;; + +(in-package "SPARC") + +(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 ndescr non-descriptor-reg nl0-offset) + ,@(when (or need-unbound-marker header variable-length) + '((:temp temp non-descriptor-reg nl1-offset))) + (:res result descriptor-reg a0-offset)) + (pseudo-atomic (ndescr) + (inst add result alloc-tn ,lowtag) + ,@(cond ((and header variable-length) + `((inst add temp extra-words (fixnum (1- ,size))) + (inst add alloc-tn alloc-tn temp) + (inst sll temp temp (- type-bits word-shift)) + (inst or temp temp ,header) + (storew temp result 0 ,lowtag) + (inst add alloc-tn (+ (fixnum 1) lowtag-mask)) + (inst and alloc-tn (lognot lowtag-mask)))) + (variable-length + (error ":REST-P T with no header in ~S?" + (primitive-object-name obj))) + (header + `((inst add alloc-tn (pad-data-block ,size)) + (inst li temp + ,(logior (ash (1- size) type-bits) + (symbol-value header))) + (storew temp result 0 ,lowtag))) + (t + `((inst add alloc-tn (pad-data-block ,size))))) + ,@(when need-unbound-marker + `((inst li temp unbound-marker-type))) + ,@(init-forms))))))) diff --git a/assembly/sparc/arith.lisp b/assembly/sparc/arith.lisp new file mode 100644 index 000000000..78ce6ad2c --- /dev/null +++ b/assembly/sparc/arith.lisp @@ -0,0 +1,286 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; 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/sparc/arith.lisp,v 1.1 1990/11/22 11:49:50 wlott Exp $ +;;; +;;; Stuff to handle simple cases for generic arithmetic. +;;; +;;; Written by William Lott. +;;; + +(in-package "SPARC") + + + +;;;; Addition and subtraction. + +(define-assembly-routine (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp cname descriptor-reg cname-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst andcc zero-tn x 3) + (inst b :ne DO-STATIC-FUN) + (inst andcc zero-tn y 3) + (inst b :ne DO-STATIC-FUN) + (inst nop) + (inst addcc temp x y) + (inst b :vc done) + (inst nop) + + (inst sra temp x 2) + (inst sra temp2 y 2) + (inst add temp2 temp) + (with-fixed-allocation (res temp vm:bignum-type 1) + (storew temp2 res vm:bignum-digits-offset vm:other-pointer-type)) + (lisp-return lra :offset 2) + + DO-STATIC-FUN + (load-symbol cname 'two-arg-+) + (inst li nargs (fixnum 2)) + (loadw code-tn cname vm:symbol-raw-function-addr-slot vm:other-pointer-type) + (inst move ocfp cfp-tn) + (inst j code-tn) + (inst move cfp-tn csp-tn) + + DONE + (move res temp)) + + +(define-assembly-routine (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp cname descriptor-reg cname-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst andcc zero-tn x 3) + (inst b :ne DO-STATIC-FUN) + (inst andcc zero-tn y 3) + (inst b :ne DO-STATIC-FUN) + (inst nop) + (inst subcc temp x y) + (inst b :vc done) + (inst nop) + + (inst sra temp x 2) + (inst sra temp2 y 2) + (inst add temp2 temp) + (with-fixed-allocation (res temp vm:bignum-type 1) + (storew temp2 res vm:bignum-digits-offset vm:other-pointer-type)) + (lisp-return lra :offset 2) + + DO-STATIC-FUN + (load-symbol cname 'two-arg--) + (inst li nargs (fixnum 2)) + (loadw code-tn cname vm:symbol-raw-function-addr-slot vm:other-pointer-type) + (inst move ocfp cfp-tn) + (inst j code-tn) + (inst move cfp-tn csp-tn) + + DONE + (move res temp)) + + + +;;;; Multiplication + +(define-assembly-routine (generic-* + (:cost 50) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp 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 andcc zero-tn x 3) + (inst b :ne DO-STATIC-FUN) + (inst andcc zero-tn y 3) + (inst b :ne 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) + (emit-multiply temp y hi res :signed) + ;; 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 xorcc temp hi) + (inst b :eq 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) + ;; Allocate a BIGNUM for the result. + (pseudo-atomic (temp) + (let ((one-word (gen-label))) + (inst add res alloc-tn other-pointer-type) + ;; Assume we need one word. + (inst add alloc-tn (pad-data-block (1+ bignum-digits-offset))) + ;; Is that correct? + (inst sra temp lo 31) + (inst xorcc temp hi) + (inst b :eq one-word) + (inst li temp (logior (ash 1 type-bits) bignum-type)) + ;; Nope, we need two, so allocate the addition space. + (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset)) + (pad-data-block (1+ bignum-digits-offset)))) + (inst li temp (logior (ash 2 type-bits) bignum-type)) + (storew hi res (1+ bignum-digits-offset) other-pointer-type) + (emit-label one-word) + (storew temp res 0 other-pointer-type) + (storew lo res bignum-digits-offset other-pointer-type))) + ;; Out of here + (lisp-return lra :offset 2) + + DO-STATIC-FUN + (load-symbol cname 'two-arg-*) + (inst li nargs (fixnum 2)) + (loadw code-tn cname symbol-raw-function-addr-slot other-pointer-type) + (inst move ocfp cfp-tn) + (inst j code-tn) + (inst move cfp-tn csp-tn) + + DONE) + +(macrolet + ((frob (name note cost type sc) + `(define-assembly-routine (,name + (:note ,note) + (:cost ,cost) + (:translate *) + (:policy :fast-safe) + (:arg-types ,type ,type) + (:result-types ,type)) + ((:arg x ,sc nl0-offset) + (:arg y ,sc nl1-offset) + (:res res ,sc nl0-offset) + (:temp temp ,sc nl2-offset)) + ,@(when (eq type 'tagged-num) + `((inst sra x 2))) + (emit-multiply x y temp res :unsigned)))) + (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg) + (frob signed-* "unsigned *" 41 signed-num signed-reg) + (frob fixnum-* "fixnum *" 30 tagged-num any-reg)) + + + +;;;; Division. + +#+assembler +(defun 32/32-restoring-divide (dividend divisor rem quo iter) + (let ((done-shifting (gen-label)) + (not-big-dividend (gen-label))) + + (inst addcc rem dividend 0) + (inst b :ge not-big-dividend) + (inst li iter (fixnum -1)) + + ;; The dividend is huge. If we shift the divisor until it's negative. + (let ((loop (gen-label))) + (inst cmp divisor) + (inst b :lt done-shifting) + (inst li quo -1) + (emit-label loop) + (inst addcc divisor divisor) + (inst b :ge loop) + (inst add iter (fixnum 1)) + (inst b done-shifting) + (inst nop)) + + ;; The dividend is not huge. Keep shifting the divisor up until it's + ;; larger than the dividend. + (emit-label not-big-dividend) + (let ((loop (gen-lable))) + (inst cmp divisor rem) + (inst b :ge done-shifting) + (inst li quo -1) + (emit-label loop) + (inst sll divisor 1) + (inst cmp quo rem) + (inst b :nc loop) + (inst add iter (fixnum 1))) + + (emit-label done-shifting) + (let ((loop-1 (gen-label)) + (loop-2 (gen-label)) + (finished (gen-label))) + (emit-label loop-1) + (inst subcc iter (fixnum 1)) + (inst b :le finished) + (emit-label loop-2) + (inst sub temp rem divisor) + (inst slr divisor 1) + (inst b :cs loop) + (inst addcc quo quo) + (inst subcc iter (fixnum 1)) + (inst b :gt loop-2) + (inst move rem temp) + (emit-label finished)) + + (inst not quo))) + + +(macrolet + ((frob (name note cost prim-type sc) + `(define-assembly-routine (,name + (:note ,note) + (:cost ,cost) + (:translate truncate) + (:policy :fast-safe) + (:arg-types ,prim-type ,prim-type) + (:result-types ,prim-type ,prim-type)) + ((:arg dividend ,sc nl0-offset) + (:arg divisor ,sc nl1-offset) + + (:res quo ,sc nl2-offset) + (:res rem ,sc nl0-offset) + + (:temp iter any-reg nl3-offset) + (:temp temp non-descriptor-reg nl4-offset)) + ))) + (frob fixnum-truncate "fixnum truncate" 50 tagged-num any-reg) + (frob signed-truncate "fixnum truncate" 60 tagged-num any-reg) + (frob unsigned-truncate "fixnum truncate" 55 tagged-num any-reg)) diff --git a/assembly/sparc/array.lisp b/assembly/sparc/array.lisp new file mode 100644 index 000000000..24ed08180 --- /dev/null +++ b/assembly/sparc/array.lisp @@ -0,0 +1,171 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; 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/sparc/array.lisp,v 1.1 1990/11/22 11:50:40 wlott Exp $ +;;; +;;; This file contains the support routines for arrays and vectors. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + + +(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 vector descriptor-reg a3-offset)) + (pseudo-atomic (ndescr) + (inst or vector alloc-tn vm:other-pointer-type) + (inst add alloc-tn alloc-tn (+ (1- (ash 1 vm:lowtag-bits)) + (* vm:vector-data-offset vm:word-bytes))) + (inst add alloc-tn alloc-tn words) + (inst and alloc-tn alloc-tn (lognot vm:lowtag-mask)) + (inst srl ndescr type vm:word-shift) + (storew ndescr vector 0 vm:other-pointer-type) + (storew length vector vm:vector-length-slot vm:other-pointer-type)) + (move result vector)) + + + +;;;; Hash primitives + +#+assembler +(defparameter sxhash-simple-substring-entry (gen-label)) + +(define-assembly-routine (sxhash-simple-string + (:translate %sxhash-simple-string) + (:policy :fast-safe) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:res result any-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp length any-reg a1-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)) + + (declare (ignore result lip accum data byte retaddr)) + + (loadw length string vm:vector-length-slot vm:other-pointer-type) + (inst b sxhash-simple-substring-entry) + (inst nop)) + + +(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)) + (emit-label sxhash-simple-substring-entry) + + ;; Save the return address. + (inst sub retaddr lip code-tn) + + (inst add lip string + (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type)) + (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 add lip lip 4) + + TEST + + (inst subcc length (fixnum 4)) + (inst b :ge loop) + (inst ld data lip 0) + + (inst addcc length (fixnum 3)) + (inst b :eq one-more) + (inst subcc length (fixnum 1)) + (inst b :eq two-more) + (inst subcc length (fixnum 1)) + (inst b :ne done) + (inst nop) + + (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 + + (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 + + (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 add lip retaddr code-tn)) + + diff --git a/assembly/sparc/assem-rtns.lisp b/assembly/sparc/assem-rtns.lisp new file mode 100644 index 000000000..32b1afd26 --- /dev/null +++ b/assembly/sparc/assem-rtns.lisp @@ -0,0 +1,242 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; 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/sparc/assem-rtns.lisp,v 1.1 1990/11/22 11:51:05 wlott Exp $ +;;; +;;; +(in-package "SPARC") + + +;;;; Return-multiple with other than one value + +#+assembler ;; we don't want a vop for this one. +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These four are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl0-offset) + (:temp ocfp any-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp count any-reg nl2-offset) + (:temp src any-reg nl3-offset) + (:temp dst any-reg 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 cmp nvals) + (inst b :le default-a0-and-on) + (inst cmp nvals (fixnum 2)) + (inst b :le default-a2-and-on) + (inst ld a1 vals (* 1 vm:word-bytes)) + (inst cmp nvals (fixnum 3)) + (inst b :le default-a3-and-on) + (inst ld a2 vals (* 2 vm:word-bytes)) + (inst cmp nvals (fixnum 4)) + (inst b :le default-a4-and-on) + (inst ld a3 vals (* 3 vm:word-bytes)) + (inst cmp nvals (fixnum 5)) + (inst b :le default-a5-and-on) + (inst ld a4 vals (* 4 vm:word-bytes)) + (inst cmp nvals (fixnum 6)) + (inst b :le done) + (inst ld a5 vals (* 5 vm:word-bytes)) + + ;; Copy the remaining args to the top of the stack. + (inst add src vals (* 6 vm:word-bytes)) + (inst add dst cfp-tn (* 6 vm:word-bytes)) + (inst subcc count nvals (fixnum 6)) + + LOOP + (inst ld temp src) + (inst add src vm:word-bytes) + (inst st temp dst) + (inst add dst vm:word-bytes) + (inst b :gt loop) + (inst subcc count (fixnum 1)) + + (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 add csp-tn ocfp-tn nvals) + + ;; Return. + (lisp-return lra)) + + + +;;;; tail-call-variable. + +#+assembler ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg nl3-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst sub nargs csp-tn args) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (inst ld a0 args (* 0 vm:word-bytes)) + (inst ld a1 args (* 1 vm:word-bytes)) + (inst ld a2 args (* 2 vm:word-bytes)) + (inst ld a3 args (* 3 vm:word-bytes)) + (inst ld a4 args (* 4 vm:word-bytes)) + (inst ld a5 args (* 5 vm:word-bytes)) + + ;; Calc SRC, DST, and COUNT + (inst addcc count nargs (fixnum (- register-arg-count))) + (inst b :le done) + (inst add src args (* vm:word-bytes register-arg-count)) + (inst add dst cfp-tn (* vm:word-bytes register-arg-count)) + + LOOP + ;; Copy one arg. + (inst ld temp src) + (inst add src src vm:word-bytes) + (inst st temp dst) + (inst addcc count (fixnum -1)) + (inst b :gt loop) + (inst add dst dst vm:word-bytes) + + DONE + ;; We are done. Do the jump. + (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type) + (lisp-jump temp)) + + + +;;;; Non-local exit noise. + +(define-assembly-routine (unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lra descriptor-reg lra-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst cmp block) + (inst b :eq error)) + + (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) + (loadw target-uwp block vm:unwind-block-current-uwp-slot) + (inst cmp cur-uwp target-uwp) + (inst b :ne do-uwp) + (inst nop) + + (move cur-uwp block) + + DO-EXIT + + (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot) + (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) + (loadw lra cur-uwp vm:unwind-block-entry-pc-slot) + (lisp-return lra :frob-code nil) + + DO-UWP + + (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot) + (inst b do-exit) + (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)) + + +(define-assembly-routine (throw + (:return-style :none)) + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset) + (:temp temp non-descriptor-reg nl0-offset)) + + (declare (ignore start count)) + + (load-symbol-value catch lisp::*current-catch-block*) + + loop + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst cmp catch) + (inst b :eq error) + (inst nop)) + + (loadw tag catch vm:catch-block-tag-slot) + (inst cmp tag target) + (inst b :eq exit) + (inst nop) + (loadw catch catch vm:catch-block-previous-catch-slot) + (inst b loop) + (inst nop) + + exit + + (move target catch) + (inst li temp (make-fixup 'unwind :assembly-routine)) + (inst j temp) + (inst nop)) + + diff --git a/assembly/sparc/support.lisp b/assembly/sparc/support.lisp new file mode 100644 index 000000000..41e0ef25f --- /dev/null +++ b/assembly/sparc/support.lisp @@ -0,0 +1,79 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; 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/sparc/support.lisp,v 1.1 1990/11/22 11:51:46 wlott Exp $ +;;; +;;; This file contains the machine specific support routines needed by +;;; the file assembler. +;;; +(in-package "SPARC") + +(def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + (:raw + (let ((temp (make-symbol "TEMP")) + (lip (make-symbol "LIP"))) + (values + `((inst li ,temp (make-fixup ',name :assembly-routine)) + (inst jal ,lip ,temp) + (inst nop)) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:scs (interior-reg) :from (:eval 0) :to (:eval 1)) + ,lip))))) + (: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) + (inst li ,temp (make-fixup ',name :assembly-routine)) + (inst j ,temp) + (inst nop) + (emit-return-pc lra-label) + (note-this-location ,vop :unknown-return) + (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))))) + (:none + (let ((temp (make-symbol "TEMP"))) + (values + `((inst li ,temp (make-fixup ',name :assembly-routine)) + (inst j ,temp) + (inst nop)) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp))))))) + +(def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `((inst j (make-random-tn :kind :normal + :sc (sc-or-lose 'interior-reg *backend*) + :offset lip-offset)) + (inst nop))) + (:full-call + `((lisp-return (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg *backend*) + :offset lra-offset) + :offset 2))) + (:none))) -- GitLab