diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp index e8c033c4f892b0c18d9fd6c27aacfbdb53e9f2d0..6d59e1943d4455584f60a34273288a87942b93fe 100644 --- a/compiler/mips/alloc.lisp +++ b/compiler/mips/alloc.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.16 1992/03/11 21:26:13 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.17 1992/07/28 20:34:12 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.16 1992/03/11 21:26:13 wlott Exp $ -;;; ;;; Allocation VOPs for the MIPS port. ;;; ;;; Written by William Lott. @@ -29,7 +27,7 @@ (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) res) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:info num) (:results (result :scs (descriptor-reg))) (:variant-vars star) @@ -41,7 +39,7 @@ (move result (tn-ref-tn things))) (t (macrolet - ((store-car (tn list &optional (slot vm:cons-car-slot)) + ((store-car (tn list &optional (slot cons-car-slot)) `(let ((reg (sc-case ,tn ((any-reg descriptor-reg) ,tn) @@ -50,27 +48,27 @@ (control-stack (load-stack-tn temp ,tn) temp)))) - (storew reg ,list ,slot vm:list-pointer-type)))) + (storew reg ,list ,slot list-pointer-type)))) (let ((cons-cells (if star (1- num) num))) - (pseudo-atomic (ndescr) - (inst addu res alloc-tn vm:list-pointer-type) - (inst addu alloc-tn alloc-tn - (* (vm:pad-data-block vm:cons-size) cons-cells)) + (pseudo-atomic (pa-flag + :extra (* (pad-data-block cons-size) + cons-cells)) + (inst or res alloc-tn list-pointer-type) (move ptr res) (dotimes (i (1- cons-cells)) (store-car (tn-ref-tn things) ptr) (setf things (tn-ref-across things)) - (inst addu ptr ptr (vm:pad-data-block vm:cons-size)) + (inst addu ptr ptr (pad-data-block cons-size)) (storew ptr ptr - (- vm:cons-cdr-slot vm:cons-size) - vm:list-pointer-type)) + (- cons-cdr-slot cons-size) + list-pointer-type)) (store-car (tn-ref-tn things) ptr) (cond (star (setf things (tn-ref-across things)) - (store-car (tn-ref-tn things) ptr vm:cons-cdr-slot)) + (store-car (tn-ref-tn things) ptr cons-cdr-slot)) (t (storew null-tn ptr - vm:cons-cdr-slot vm:list-pointer-type))) + cons-cdr-slot list-pointer-type))) (assert (null (tn-ref-across things))) (move result res)))))))) @@ -90,32 +88,34 @@ (:temporary (:scs (non-descriptor-reg)) ndescr) (:temporary (:scs (any-reg) :from (:argument 0)) boxed) (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:generator 100 - (inst li ndescr (lognot vm:lowtag-mask)) - (inst addu boxed boxed-arg (fixnum (1+ vm:code-trace-table-offset-slot))) + (inst li ndescr (lognot lowtag-mask)) + (inst addu boxed boxed-arg (fixnum (1+ code-trace-table-offset-slot))) (inst and boxed ndescr) - (inst srl unboxed unboxed-arg vm:word-shift) - (inst addu unboxed unboxed vm:lowtag-mask) + (inst srl unboxed unboxed-arg word-shift) + (inst addu unboxed unboxed lowtag-mask) (inst and unboxed ndescr) - (pseudo-atomic (ndescr) - (inst addu result alloc-tn vm:other-pointer-type) + (pseudo-atomic (pa-flag) + (inst or result alloc-tn other-pointer-type) (inst addu alloc-tn boxed) (inst addu alloc-tn unboxed) - (inst sll ndescr boxed (- vm:type-bits vm:word-shift)) - (inst or ndescr vm:code-header-type) - (storew ndescr result 0 vm:other-pointer-type) - (storew unboxed result vm:code-code-size-slot vm:other-pointer-type) - (storew null-tn result vm:code-entry-points-slot vm:other-pointer-type) - (storew null-tn result vm:code-debug-info-slot vm:other-pointer-type)))) + (inst sll ndescr boxed (- type-bits word-shift)) + (inst or ndescr code-header-type) + (storew ndescr result 0 other-pointer-type) + (storew unboxed result code-code-size-slot other-pointer-type) + (storew null-tn result code-entry-points-slot other-pointer-type) + (storew null-tn result code-debug-info-slot other-pointer-type)))) (define-vop (make-fdefn) (:policy :fast-safe) (:translate make-fdefn) (:args (name :scs (descriptor-reg) :to :eval)) (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:results (result :scs (descriptor-reg) :from :argument)) (:generator 37 - (with-fixed-allocation (result temp fdefn-type fdefn-size) + (with-fixed-allocation (result pa-flag temp fdefn-type fdefn-size) (storew name result fdefn-name-slot other-pointer-type) (storew null-tn result fdefn-function-slot other-pointer-type) (inst li temp (make-fixup "undefined_tramp" :foreign)) @@ -124,85 +124,85 @@ ;;;; Automatic allocators for primitive objects. -(vm:define-for-each-primitive-object (obj) - (collect ((forms)) - (let* ((options (vm:primitive-object-options obj)) - (alloc-trans (getf options :alloc-trans)) - (alloc-vop (getf options :alloc-vop alloc-trans)) - (header (vm:primitive-object-header obj)) - (lowtag (vm:primitive-object-lowtag obj)) - (size (vm:primitive-object-size obj)) - (variable-length (vm:primitive-object-variable-length obj)) - (need-unbound-marker nil)) - (collect ((args) (init-forms)) - (when (and alloc-vop variable-length) - (args 'extra-words)) - (dolist (slot (vm:primitive-object-slots obj)) - (let* ((name (vm:slot-name slot)) - (offset (vm:slot-offset slot))) - (ecase (getf (vm: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) (vm:primitive-object-name obj))) - (when alloc-vop - (forms - `(define-vop (,alloc-vop) - (:args ,@(mapcar #'(lambda (name) - `(,name :scs (any-reg descriptor-reg))) - (args))) - (:temporary (:scs (non-descriptor-reg) :type random) - ndescr - ,@(when (or need-unbound-marker header - variable-length) - '(temp))) - (:temporary (:scs (descriptor-reg) :to (:result 0) - :target real-result) result) - (:results (real-result :scs (descriptor-reg))) - (:policy :fast-safe) - ,@(when alloc-trans - `((:translate ,alloc-trans))) - (:generator 37 - (pseudo-atomic (ndescr) - (inst addu result alloc-tn ,lowtag) - ,@(cond ((and header variable-length) - `((inst addu temp extra-words - (fixnum (1- ,size))) - (inst addu alloc-tn alloc-tn temp) - (inst sll temp temp - (- vm:type-bits vm:word-shift)) - (inst or temp temp ,header) - (storew temp result 0 ,lowtag) - (inst addu alloc-tn alloc-tn - (+ (fixnum 1) vm:lowtag-mask)) - (inst li temp (lognot vm:lowtag-mask)) - (inst and alloc-tn alloc-tn temp))) - (variable-length - (error ":REST-P T with no header in ~S?" - (vm:primitive-object-name obj))) - (header - `((inst addu alloc-tn alloc-tn - (vm:pad-data-block ,size)) - (inst li temp - ,(logior (ash (1- size) vm:type-bits) - (symbol-value header))) - (storew temp result 0 ,lowtag))) - (t - `((inst addu alloc-tn alloc-tn - (vm:pad-data-block ,size))))) - ,@(when need-unbound-marker - `((inst li temp vm:unbound-marker-type))) - ,@(init-forms) - (move real-result result)))))))) - (when (forms) - `(progn - ,@(forms))))) +(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-vop (,alloc-vop) + (:args ,@(mapcar #'(lambda (name) + `(,name :scs (any-reg descriptor-reg))) + (args))) + (:temporary (:scs (non-descriptor-reg)) + ,@(when (or header need-unbound-marker) + '(temp)) + ,@(when variable-length '(temp2))) + (:temporary (:scs (descriptor-reg) :to (:result 0) + :target real-result) result) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) + (:results (real-result :scs (descriptor-reg))) + (:policy :fast-safe) + ,@(when alloc-trans + `((:translate ,alloc-trans))) + (:generator ,(+ 4 + (length (init-forms)) + (if header 2 0) + (if variable-length 6 0) + (if need-unbound-marker 1 0)) + (pseudo-atomic + (pa-flag :extra ,(if variable-length + 0 + `(pad-data-block ,size))) + (inst or result alloc-tn ,lowtag) + ,@(cond ((and header variable-length) + `((inst addu temp extra-words (fixnum (1+ ,size))) + (inst li temp2 (lognot lowtag-mask)) + (inst and temp temp2) + (inst addu alloc-tn temp) + (inst addu temp extra-words (fixnum (1- ,size))) + (inst sll temp extra-words + (- type-bits word-shift)) + (inst or temp temp ,header) + (storew temp result 0 ,lowtag))) + (variable-length + (error ":REST-P T with no header in ~S?" + (primitive-object-name obj))) + (header + `((inst addu alloc-tn 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 addu alloc-tn alloc-tn + (pad-data-block ,size))))) + ,@(when need-unbound-marker + `((inst li temp unbound-marker-type))) + ,@(init-forms) + (move real-result result)))))))) diff --git a/compiler/mips/arith.lisp b/compiler/mips/arith.lisp index 3bdab2ae2c6b1502bd67693c07972e2b06501575..872a16a839be30851d0882b6d92025bd9178d958 100644 --- a/compiler/mips/arith.lisp +++ b/compiler/mips/arith.lisp @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.45 1992/03/27 19:35:24 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.46 1992/07/28 20:37:12 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.45 1992/03/27 19:35:24 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.46 1992/07/28 20:37:12 wlott Exp $ ;;; ;;; This file contains the VM definition arithmetic VOPs for the MIPS. ;;; @@ -104,112 +104,112 @@ (:affected) (:policy :fast-safe)) -(defmacro define-binop (translate cost op &optional unsigned) +(define-vop (fast-fixnum-c-binop fast-fixnum-binop) + (:args (x :target r :scs (any-reg))) + (:info y) + (:arg-types tagged-num (:constant integer))) + +(define-vop (fast-signed-c-binop fast-signed-binop) + (:args (x :target r :scs (signed-reg))) + (:info y) + (:arg-types tagged-num (:constant integer))) + +(define-vop (fast-unsigned-c-binop fast-unsigned-binop) + (:args (x :target r :scs (unsigned-reg))) + (:info y) + (:arg-types tagged-num (:constant integer))) + +(defmacro define-binop (translate cost untagged-cost op + tagged-type untagged-type) `(progn - (define-vop (,(intern (concatenate 'simple-string - "FAST-" - (string translate) - "/FIXNUM=>FIXNUM")) + (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") fast-fixnum-binop) - (:args (x :target r - :scs (any-reg)) - (y :target r - :scs (any-reg immediate zero - ,(if unsigned - 'unsigned-immediate - 'negative-immediate)))) + (:args (x :target r :scs (any-reg)) + (y :target r :scs (any-reg))) (:translate ,translate) (:generator ,cost - (inst ,op r x - (sc-case y - (any-reg y) - (zero zero-tn) - ((immediate - ,(if unsigned 'unsigned-immediate 'negative-immediate)) - (fixnum (tn-value y))))))) - (define-vop (,(intern (concatenate 'simple-string - "FAST-" - (string translate) - "/SIGNED=>SIGNED")) + (inst ,op r x y))) + (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") fast-signed-binop) - (:args (x :target r - :scs (signed-reg)) - (y :target r - :scs (signed-reg immediate zero - ,(if unsigned - 'unsigned-immediate - 'negative-immediate)))) + (:args (x :target r :scs (signed-reg)) + (y :target r :scs (signed-reg))) (:translate ,translate) - (:generator ,(1+ cost) - (inst ,op r x - (sc-case y - (signed-reg y) - (zero zero-tn) - ((immediate - ,(if unsigned 'unsigned-immediate 'negative-immediate)) - (tn-value y)))))) - (define-vop (,(intern (concatenate 'simple-string - "FAST-" - (string translate) - "/UNSIGNED=>UNSIGNED")) + (:generator ,untagged-cost + (inst ,op r x y))) + (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") fast-unsigned-binop) - (:args (x :target r - :scs (unsigned-reg)) - (y :target r - :scs (unsigned-reg immediate zero - ,(if unsigned - 'unsigned-immediate - 'negative-immediate)))) + (:args (x :target r :scs (unsigned-reg)) + (y :target r :scs (unsigned-reg))) + (:translate ,translate) + (:generator ,untagged-cost + (inst ,op r x y))) + (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") + fast-fixnum-c-binop) + (:arg-types tagged-num (:constant ,tagged-type)) + (:translate ,translate) + (:generator ,cost + (inst ,op r x (fixnum y)))) + (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") + fast-signed-c-binop) + (:arg-types signed-num (:constant ,untagged-type)) (:translate ,translate) - (:generator ,(1+ cost) - (inst ,op r x - (sc-case y - (unsigned-reg y) - (zero zero-tn) - ((immediate - ,(if unsigned 'unsigned-immediate 'negative-immediate)) - (tn-value y)))))))) - -(define-binop + 2 addu) -(define-binop - 2 subu) -(define-binop logior 1 or t) -(define-binop logand 1 and t) -(define-binop logxor 1 xor t) - -;;; Special case fixnum + and - that don't check for overflow. Useful when we -;;; know the output type is a fixnum. + (:generator ,untagged-cost + (inst ,op r x y))) + (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED") + fast-unsigned-c-binop) + (:arg-types unsigned-num (:constant ,untagged-type)) + (:translate ,translate) + (:generator ,untagged-cost + (inst ,op r x y))))) + +(define-binop + 2 6 addu (signed-byte 14) (signed-byte 16)) +(define-binop - 2 6 subu + (integer #.(- (1- (ash 1 14))) #.(ash 1 14)) + (integer #.(- (1- (ash 1 16))) #.(ash 1 16))) +(define-binop logior 1 2 or (unsigned-byte 14) (unsigned-byte 16)) +(define-binop lognor 1 2 nor (unsigned-byte 14) (unsigned-byte 16)) +(define-binop logand 1 2 and (unsigned-byte 14) (unsigned-byte 16)) +(define-binop logxor 1 2 xor (unsigned-byte 14) (unsigned-byte 16)) + +;;; Special case fixnum + and - that trap on overflow. Useful when we don't +;;; know that the result is going to be a fixnum. (define-vop (fast-+/fixnum fast-+/fixnum=>fixnum) (:results (r :scs (any-reg descriptor-reg))) (:result-types (:or signed-num unsigned-num)) (:note nil) - (:generator 1 - (inst add r x - (sc-case y - (any-reg y) - (zero zero-tn) - ((immediate negative-immediate) - (fixnum (tn-value y))))))) + (:generator 4 + (inst add r x y))) + +(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) + (:note nil) + (:generator 3 + (inst add r x (fixnum y)))) (define-vop (fast--/fixnum fast--/fixnum=>fixnum) (:results (r :scs (any-reg descriptor-reg))) (:result-types (:or signed-num unsigned-num)) (:note nil) - (:generator 1 - (inst sub r x - (sc-case y - (any-reg y) - (zero zero-tn) - ((immediate negative-immediate) - (fixnum (tn-value y))))))) + (:generator 4 + (inst sub r x y))) + +(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) + (:note nil) + (:generator 3 + (inst sub r x (fixnum y)))) ;;; Shifting + (define-vop (fast-ash) (:note "inline ASH") (:args (number :scs (signed-reg unsigned-reg) :to :save) - (amount :scs (signed-reg immediate negative-immediate))) + (amount :scs (signed-reg))) (:arg-types (:or signed-num unsigned-num) signed-num) (:results (result :scs (signed-reg unsigned-reg))) (:result-types (:or signed-num unsigned-num)) @@ -218,39 +218,43 @@ (:temporary (:sc non-descriptor-reg) ndesc) (:temporary (:sc non-descriptor-reg :to :eval) temp) (:generator 3 - (sc-case amount - (signed-reg - (let ((positive (gen-label)) - (done (gen-label))) - (inst bgez amount positive) - (inst subu ndesc zero-tn amount) - (inst slt temp ndesc 31) - (inst bne temp zero-tn done) - (sc-case number - (signed-reg (inst sra result number ndesc)) - (unsigned-reg (inst srl result number ndesc))) - (inst b done) - (sc-case number - (signed-reg (inst sra result number 31)) - (unsigned-reg (inst srl result number 31))) - - (emit-label positive) - ;; The result-type assures us that this shift will not overflow. - (inst sll result number amount) - - (emit-label done))) - - ((immediate negative-immediate) - (let ((amount (tn-value amount))) - (if (minusp amount) - (sc-case number - (unsigned-reg - (inst srl result number (- amount))) - (t - (inst sra result number (- amount)))) - (inst sll result number amount))))))) - + (inst bgez amount positive) + (inst subu ndesc zero-tn amount) + (inst slt temp ndesc 31) + (inst bne temp zero-tn done) + (sc-case number + (signed-reg (inst sra result number ndesc)) + (unsigned-reg (inst srl result number ndesc))) + (inst b done) + (sc-case number + (signed-reg (inst sra result number 31)) + (unsigned-reg (inst srl result number 31))) + + POSITIVE + ;; The result-type assures us that this shift will not overflow. + (inst sll result number amount) + + DONE)) +(define-vop (fast-ash-c) + (:policy :fast-safe) + (:translate ash) + (:note nil) + (:args (number :scs (signed-reg unsigned-reg))) + (:info count) + (:arg-types (:or signed-num unsigned-num) (:constant integer)) + (:results (result :scs (signed-reg unsigned-reg))) + (:result-types (:or signed-num unsigned-num)) + (:generator 1 + (cond ((< count 0) + ;; It is a right shift. + (inst sra result number (min (- count) 31))) + ((> count 0) + ;; It is a left shift. + (inst sll result number (min count 31))) + (t + ;; Count=0? Shouldn't happen, but it's easy: + (move result number))))) (define-vop (signed-byte-32-len) (:translate integer-length) @@ -319,7 +323,7 @@ ;;; Multiply and Divide. (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) - (:temporary (:scs (non-descriptor-reg) :type random) temp) + (:temporary (:scs (non-descriptor-reg)) temp) (:translate *) (:generator 4 (inst sra temp y 2) @@ -675,34 +679,24 @@ (:translate bignum::%bignum-set-length) (:policy :fast-safe)) -(define-vop (bignum-ref word-index-ref) - (:variant vm:bignum-digits-offset vm:other-pointer-type) - (:translate bignum::%bignum-ref) - (:results (value :scs (unsigned-reg))) - (:result-types unsigned-num)) +(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type + (unsigned-reg) unsigned-num bignum::%bignum-ref) -(define-vop (bignum-set word-index-set) - (:variant vm:bignum-digits-offset vm:other-pointer-type) - (:translate bignum::%bignum-set) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg immediate zero negative-immediate)) - (value :scs (unsigned-reg))) - (:arg-types t positive-fixnum unsigned-num) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num)) +(define-full-setter bignum-set * bignum-digits-offset other-pointer-type + (unsigned-reg) unsigned-num bignum::%bignum-set) (define-vop (digit-0-or-plus) (:translate bignum::%digit-0-or-plusp) (:policy :fast-safe) (:args (digit :scs (unsigned-reg))) (:arg-types unsigned-num) - (:results (result :scs (descriptor-reg))) - (:generator 3 - (let ((done (gen-label))) - (inst bltz digit done) - (move result null-tn) - (load-symbol result 't) - (emit-label done)))) + (:conditional) + (:info target not-p) + (:generator 2 + (if not-p + (inst bltz digit target) + (inst bgez digit target)) + (inst nop))) (define-vop (add-w/carry) (:translate bignum::%add-with-carry) diff --git a/compiler/mips/array.lisp b/compiler/mips/array.lisp index 74117a1dc2759b3d2a3e1aac96255aa6e36d924e..8e237116c0acfa78f7d9dd59081130ef109c4832 100644 --- a/compiler/mips/array.lisp +++ b/compiler/mips/array.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.34 1992/07/08 20:55:30 hallgren Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.35 1992/07/28 20:37:15 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.34 1992/07/08 20:55:30 hallgren Exp $ -;;; ;;; This file contains the MIPS definitions for array operations. ;;; ;;; Written by William Lott @@ -29,56 +27,54 @@ (rank :scs (any-reg))) (:arg-types positive-fixnum positive-fixnum) (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (:temporary (:scs (any-reg)) temp1) + (:temporary (:scs (non-descriptor-reg)) temp2) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:results (result :scs (descriptor-reg))) - (:generator 25 - (pseudo-atomic (ndescr) - (inst addu header alloc-tn vm:other-pointer-type) - (inst addu alloc-tn - (+ (* vm:array-dimensions-offset vm:word-bytes) - vm:lowtag-mask)) - (inst addu alloc-tn rank) - (inst li ndescr (lognot vm:lowtag-mask)) - (inst and alloc-tn ndescr) - (inst addu ndescr rank (fixnum (1- vm:array-dimensions-offset))) - (inst sll ndescr ndescr vm:type-bits) - (inst or ndescr ndescr type) - (inst srl ndescr ndescr 2) - (storew ndescr header 0 vm:other-pointer-type)) + (:generator 13 + (pseudo-atomic (pa-flag) + (inst or header alloc-tn other-pointer-type) + (inst addu temp1 rank (+ (* array-dimensions-offset word-bytes) + lowtag-mask)) + (inst li temp2 (lognot lowtag-mask)) + (inst and temp1 temp2) + (inst addu alloc-tn temp1) + (inst addu temp2 rank (fixnum (1- array-dimensions-offset))) + (inst sll temp2 type-bits) + (inst or temp2 temp2 type) + (inst srl temp2 2) + (storew temp2 header 0 other-pointer-type)) (move result header))) ;;;; Additional accessors and setters for the array header. -(defknown lisp::%array-dimension (t fixnum) fixnum +(defknown lisp::%array-dimension (t index) index (flushable)) -(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum +(defknown lisp::%set-array-dimension (t index index) index ()) -(define-vop (%array-dimension word-index-ref) - (:translate lisp::%array-dimension) - (:policy :fast-safe) - (:variant vm:array-dimensions-offset vm:other-pointer-type)) +(define-full-reffer %array-dimension * + array-dimensions-offset other-pointer-type + (any-reg) positive-fixnum lisp::%array-dimension) -(define-vop (%set-array-dimension word-index-set) - (:translate lisp::%set-array-dimension) - (:policy :fast-safe) - (:variant vm:array-dimensions-offset vm:other-pointer-type)) +(define-full-setter %set-array-dimension * + array-dimensions-offset other-pointer-type + (any-reg) positive-fixnum lisp::%set-array-dimension) - -(defknown lisp::%array-rank (t) fixnum (flushable)) +(defknown lisp::%array-rank (t) index (flushable)) (define-vop (array-rank-vop) (:translate lisp::%array-rank) (:policy :fast-safe) (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :type random) temp) + (:temporary (:scs (non-descriptor-reg)) temp) (:results (res :scs (any-reg descriptor-reg))) (:generator 6 - (loadw temp x 0 vm:other-pointer-type) - (inst sra temp vm:type-bits) - (inst subu temp (1- vm:array-dimensions-offset)) + (loadw temp x 0 other-pointer-type) + (inst sra temp type-bits) + (inst subu temp (1- array-dimensions-offset)) (inst sll res temp 2))) @@ -93,7 +89,7 @@ (bound :scs (any-reg descriptor-reg)) (index :scs (any-reg descriptor-reg) :target result)) (:results (result :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :type random) temp) + (:temporary (:scs (non-descriptor-reg)) temp) (:vop-var vop) (:save-p :compute-only) (:generator 5 @@ -112,47 +108,43 @@ ;;; elements are represented in integer registers and are built out of ;;; 8, 16, or 32 bit elements. -(defmacro def-data-vector-frobs (type variant element-type &rest scs) +(eval-when (compile eval) + +(defmacro def-full-data-vector-frobs (type element-type &rest scs) `(progn - (define-vop (,(intern (concatenate 'simple-string - "DATA-VECTOR-REF/" - (string type))) - ,(intern (concatenate 'simple-string - (string variant) - "-REF"))) - (:note "inline array access") - (:variant vm:vector-data-offset vm:other-pointer-type) - (:translate data-vector-ref) - (:arg-types ,type positive-fixnum) - (:results (value :scs ,scs)) - (:result-types ,element-type)) - (define-vop (,(intern (concatenate 'simple-string - "DATA-VECTOR-SET/" - (string type))) - ,(intern (concatenate 'simple-string - (string variant) - "-SET"))) - (:note "inline array store") - (:variant vm:vector-data-offset vm:other-pointer-type) - (:translate data-vector-set) - (:arg-types ,type positive-fixnum ,element-type) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg zero immediate unsigned-immediate)) - (value :scs ,scs)) - (:results (result :scs ,scs)) - (:result-types ,element-type)))) - -(def-data-vector-frobs simple-string byte-index - base-char base-char-reg) -(def-data-vector-frobs simple-vector word-index - * descriptor-reg any-reg) - -(def-data-vector-frobs simple-array-unsigned-byte-8 byte-index - positive-fixnum unsigned-reg) -(def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index - positive-fixnum unsigned-reg) -(def-data-vector-frobs simple-array-unsigned-byte-32 word-index - unsigned-num unsigned-reg) + (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type + vector-data-offset other-pointer-type ,scs ,element-type + data-vector-ref) + (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type + vector-data-offset other-pointer-type ,scs ,element-type + data-vector-set))) + +(defmacro def-partial-data-vector-frobs + (type element-type size signed &rest scs) + `(progn + (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type + ,size ,signed vector-data-offset other-pointer-type ,scs + ,element-type data-vector-ref) + (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type + ,size vector-data-offset other-pointer-type ,scs + ,element-type data-vector-set))) + +); eval-when (compile eval) + +(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg) + +(def-partial-data-vector-frobs simple-string base-char :byte :leave-alone + base-char-reg) + +(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum + :byte nil unsigned-reg signed-reg) + +(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum + :short nil unsigned-reg signed-reg) + +(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num + unsigned-reg) + ;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, @@ -160,7 +152,7 @@ ;;; (defmacro def-small-data-vector-frobs (type bits) - (let* ((elements-per-word (floor vm:word-bits bits)) + (let* ((elements-per-word (floor word-bits bits)) (bit-shift (1- (integer-length elements-per-word)))) `(progn (define-vop (,(symbolicate 'data-vector-ref/ type)) @@ -179,8 +171,8 @@ (inst sll temp 2) (inst addu lip object temp) (inst lw result lip - (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) + (- (* vector-data-offset word-bytes) + other-pointer-type)) (inst and temp index ,(1- elements-per-word)) ,@(when (eq (backend-byte-order *backend*) :big-endian) `((inst xor temp ,(1- elements-per-word)))) @@ -197,9 +189,9 @@ (:constant (integer 0 ,(1- (* (1+ (- (floor (+ #x7fff - vm:other-pointer-type) - vm:word-bytes) - vm:vector-data-offset)) + other-pointer-type) + word-bytes) + vector-data-offset)) elements-per-word))))) (:info index) (:results (result :scs (unsigned-reg))) @@ -208,8 +200,8 @@ (multiple-value-bind (word extra) (floor index ,elements-per-word) ,@(when (eq (backend-byte-order *backend*) :big-endian) `((setf extra (logxor extra (1- ,elements-per-word))))) - (loadw result object (+ word vm:vector-data-offset) - vm:other-pointer-type) + (loadw result object (+ word vector-data-offset) + other-pointer-type) (unless (zerop extra) (inst srl result (* extra ,bits))) (unless (= extra ,(1- elements-per-word)) @@ -232,8 +224,8 @@ (inst sll temp 2) (inst addu lip object temp) (inst lw old lip - (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) + (- (* vector-data-offset word-bytes) + other-pointer-type)) (inst and shift index ,(1- elements-per-word)) ,@(when (eq (backend-byte-order *backend*) :big-endian) `((inst xor shift ,(1- elements-per-word)))) @@ -254,8 +246,8 @@ (inst sll temp shift) (inst or old temp)) (inst sw old lip - (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) + (- (* vector-data-offset word-bytes) + other-pointer-type)) (sc-case value (immediate (inst li result (tn-value value))) @@ -272,9 +264,9 @@ (:constant (integer 0 ,(1- (* (1+ (- (floor (+ #x7fff - vm:other-pointer-type) - vm:word-bytes) - vm:vector-data-offset)) + other-pointer-type) + word-bytes) + vector-data-offset)) elements-per-word)))) positive-fixnum) (:info index) @@ -286,8 +278,8 @@ ,@(when (eq (backend-byte-order *backend*) :big-endian) `((setf extra (logxor extra (1- ,elements-per-word))))) (inst lw old object - (- (* (+ word vm:vector-data-offset) vm:word-bytes) - vm:other-pointer-type)) + (- (* (+ word vector-data-offset) word-bytes) + other-pointer-type)) (unless (and (sc-is value immediate) (= (tn-value value) ,(1- (ash 1 bits)))) (cond ((= extra ,(1- elements-per-word)) @@ -311,8 +303,8 @@ (inst sll temp value (* extra ,bits)) (inst or old temp))) (inst sw old object - (- (* (+ word vm:vector-data-offset) vm:word-bytes) - vm:other-pointer-type)) + (- (* (+ word vector-data-offset) word-bytes) + other-pointer-type)) (sc-case value (immediate (inst li result (tn-value value))) @@ -342,8 +334,8 @@ (:generator 20 (inst addu lip object index) (inst lwc1 value lip - (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) + (- (* vector-data-offset word-bytes) + other-pointer-type)) (inst nop))) (define-vop (data-vector-set/simple-array-single-float) @@ -360,8 +352,8 @@ (:generator 20 (inst addu lip object index) (inst swc1 value lip - (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) + (- (* vector-data-offset word-bytes) + other-pointer-type)) (unless (location= result value) (inst fmove :single result value)))) @@ -379,12 +371,12 @@ (inst addu lip object index) (inst addu lip index) (inst lwc1 value lip - (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) + (- (* vector-data-offset word-bytes) + other-pointer-type)) (inst lwc1-odd value lip - (+ (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type) - vm:word-bytes)) + (+ (- (* vector-data-offset word-bytes) + other-pointer-type) + word-bytes)) (inst nop))) (define-vop (data-vector-set/simple-array-double-float) @@ -402,12 +394,12 @@ (inst addu lip object index) (inst addu lip index) (inst swc1 value lip - (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) + (- (* vector-data-offset word-bytes) + other-pointer-type)) (inst swc1-odd value lip - (+ (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type) - vm:word-bytes)) + (+ (- (* vector-data-offset word-bytes) + other-pointer-type) + word-bytes)) (unless (location= result value) (inst fmove :double result value)))) @@ -417,38 +409,15 @@ ;;; what type of vector it is. ;;; -(define-vop (raw-bits word-index-ref) - (:note "raw-bits VOP") - (:translate %raw-bits) - (:results (value :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant 0 vm:other-pointer-type)) - -(define-vop (set-raw-bits word-index-set) - (:note "setf raw-bits VOP") - (:translate %set-raw-bits) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg zero immediate unsigned-immediate)) - (value :scs (unsigned-reg))) - (:arg-types * positive-fixnum unsigned-num) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant 0 vm:other-pointer-type)) - +(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num + %raw-bits) +(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg) + unsigned-num %set-raw-bits) ;;;; Misc. Array VOPs. - -#+nil -(define-vop (vector-word-length) - (:args (vec :scs (descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadw res vec clc::g-vector-header-words) - (inst niuo res res clc::g-vector-words-mask-16))) - (define-vop (get-vector-subtype get-header-data)) (define-vop (set-vector-subtype set-header-data)) diff --git a/compiler/mips/c-call.lisp b/compiler/mips/c-call.lisp index fdf5cfa3f15760a5f8df294727d4144125c2fbba..93e1aef92ed466f03a8151347e9e75edd7caa95d 100644 --- a/compiler/mips/c-call.lisp +++ b/compiler/mips/c-call.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.11 1992/03/27 23:25:38 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.12 1992/07/28 20:37:17 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.11 1992/03/27 23:25:38 wlott Exp $ -;;; ;;; This file contains the VOPs and other necessary machine specific support ;;; routines for call-out to C. ;;; @@ -156,30 +154,22 @@ (inst li res (make-fixup foreign-symbol :foreign)))) (define-vop (call-out) - (:args (function :scs (sap-reg) :target v0) + (:args (function :scs (sap-reg) :target cfunc) (args :more t)) (:results (results :more t)) (:ignore args results) (:save-p t) - (:temporary (:sc any-reg :offset 2 :from (:argument 0) :to (:result 0)) v0) - (:temporary (:sc any-reg :offset lra-offset) lra) - (:temporary (:sc any-reg :offset code-offset) code) - (:temporary (:sc non-descriptor-reg :to (:result 0)) ndescr) + (:temporary (:sc any-reg :offset cfunc-offset + :from (:argument 0) :to (:result 0)) cfunc) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:vop-var vop) (:generator 0 - (let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn vop))) + (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) - (move v0 function) - (inst compute-lra-from-code lra code lra-label ndescr) - (inst j (make-fixup "call_into_c" :foreign)) + (move cfunc function) + (inst jal (make-fixup "call_into_c" :foreign)) (inst nop) - - (align vm:lowtag-bits) - (emit-label lra-label) - (inst lra-header-word) (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) diff --git a/compiler/mips/call.lisp b/compiler/mips/call.lisp index b382cf20c16545108ba60befed568f791f3c2344..635860c725d77b43a8cb12e3c8b1a94526fb8740 100644 --- a/compiler/mips/call.lisp +++ b/compiler/mips/call.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.48 1992/05/21 22:34:26 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.49 1992/07/28 20:37:20 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.48 1992/05/21 22:34:26 wlott Exp $ -;;; ;;; This file contains the VM definition of function call for the MIPS. ;;; ;;; Written by Rob MacLachlan @@ -60,7 +58,7 @@ ;;; (def-vm-support-routine make-old-fp-passing-location (standard) (if standard - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn old-fp-offset) + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset) (make-normal-tn *fixnum-primitive-type*))) ;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface @@ -74,7 +72,7 @@ (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) (make-wired-tn *fixnum-primitive-type* control-stack-arg-scn - old-fp-save-offset))) + ocfp-save-offset))) ;;; (def-vm-support-routine make-return-pc-save-location (env) (specify-save-tn @@ -154,7 +152,7 @@ (define-vop (current-fp) (:results (val :scs (any-reg))) (:generator 1 - (move val fp-tn))) + (move val cfp-tn))) ;;; Used for computing the caller's NFP for use in known-values return. Only ;;; works assuming there is no variable size stuff on the nstack. @@ -188,7 +186,7 @@ (emit-label entry-point) (inst compute-code-from-fn code-tn lip-tn entry-point temp)) ;; Build our stack frames. - (inst addu csp-tn fp-tn + (inst addu csp-tn cfp-tn (* vm:word-bytes (sb-allocated-size 'control-stack))) (let ((nfp (current-nfp-tn vop))) (when nfp @@ -260,25 +258,25 @@ move a1 null-tn ; Default register values ... loadi nargs 1 ; Force defaulting of stack values - move old-fp csp ; Set up args for SP resetting + move ocfp csp ; Set up args for SP resetting regs-defaulted subu temp nargs register-arg-count bltz temp default-value-7 ; jump to default code addu temp temp -1 - loadw move-temp old-fp-tn 6 ; Move value to correct location. + loadw move-temp ocfp-tn 6 ; Move value to correct location. store-stack-tn val4-tn move-temp bltz temp default-value-8 addu temp temp -1 - loadw move-temp old-fp-tn 7 + loadw move-temp ocfp-tn 7 store-stack-tn val5-tn move-temp ... defaulting-done - move sp old-fp ; Reset SP. + move sp ocfp ; Reset SP. <end of code> <elsewhere> @@ -303,23 +301,23 @@ default-value-8 ;; the multiple-value entry point for a single desired value, but ;; the code location has to be here, or the debugger backtrace ;; gets confused. - (note-this-location vop :single-value-return) - (move csp-tn old-fp-tn) - (inst nop) - (inst entry-point) + (without-scheduling () + (note-this-location vop :single-value-return) + (move csp-tn ocfp-tn) + (inst nop)) (inst compute-code-from-lra code-tn code-tn lra-label temp)) (let ((regs-defaulted (gen-label)) (defaulting-done (gen-label)) (default-stack-vals (gen-label))) - ;; Note that this is an unknown-values return point. - (note-this-location vop :unknown-return) - ;; Branch off to the MV case. - (inst b regs-defaulted) - ;; If there are no stack results, clear the stack now. - (if (> nvals register-arg-count) - (inst addu temp nargs-tn (fixnum (- register-arg-count))) - (move csp-tn old-fp-tn)) - (inst entry-point) + (without-scheduling () + ;; Note that this is an unknown-values return point. + (note-this-location vop :unknown-return) + ;; Branch off to the MV case. + (inst b regs-defaulted) + ;; If there are no stack results, clear the stack now. + (if (> nvals register-arg-count) + (inst addu temp nargs-tn (fixnum (- register-arg-count))) + (move csp-tn ocfp-tn))) ;; Do the single value calse. (do ((i 1 (1+ i)) @@ -328,7 +326,7 @@ default-value-8 (move (tn-ref-tn val) null-tn)) (when (> nvals register-arg-count) (inst b default-stack-vals) - (move old-fp-tn csp-tn)) + (move ocfp-tn csp-tn)) (emit-label regs-defaulted) @@ -348,12 +346,12 @@ default-value-8 (defaults (cons default-lab tn)) (inst bltz temp default-lab) - (inst lw move-temp old-fp-tn (* i vm:word-bytes)) + (inst lw move-temp ocfp-tn (* i vm:word-bytes)) (inst addu temp temp (fixnum -1)) (store-stack-tn tn move-temp))) (emit-label defaulting-done) - (move csp-tn old-fp-tn) + (move csp-tn ocfp-tn) (let ((defaults (defaults))) (assert defaults) @@ -398,9 +396,9 @@ default-value-8 (declare (type tn args nargs start count temp)) (let ((variable-values (gen-label)) (done (gen-label))) - (inst b variable-values) - (inst nop) - (inst entry-point) + (without-scheduling () + (inst b variable-values) + (inst nop)) (inst compute-code-from-lra code-tn code-tn lra-label temp) (inst addu csp-tn csp-tn 4) @@ -433,7 +431,7 @@ default-value-8 (:results (start :scs (any-reg)) (count :scs (any-reg))) - (:temporary (:sc descriptor-reg :offset old-fp-offset + (:temporary (:sc descriptor-reg :offset ocfp-offset :from :eval :to (:result 0)) values-start) (:temporary (:sc any-reg :offset nargs-offset @@ -475,7 +473,7 @@ default-value-8 (:temporary (:scs (descriptor-reg) :from :eval) move-temp) (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:sc any-reg :offset old-fp-offset :from :eval) ocfp) + (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp) (:ignore arg-locs args ocfp) (:generator 5 (trace-table-entry trace-table-call-site) @@ -486,7 +484,7 @@ default-value-8 (let ((callee-nfp (callee-nfp-tn callee))) (when callee-nfp (move callee-nfp nfp))) - (maybe-load-stack-tn fp-tn fp) + (maybe-load-stack-tn cfp-tn fp) (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) @@ -526,7 +524,7 @@ default-value-8 (let ((callee-nfp (callee-nfp-tn callee))) (when callee-nfp (move callee-nfp nfp))) - (maybe-load-stack-tn fp-tn fp) + (maybe-load-stack-tn cfp-tn fp) (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) @@ -570,7 +568,7 @@ default-value-8 (let ((callee-nfp (callee-nfp-tn callee))) (when callee-nfp (move callee-nfp nfp))) - (maybe-load-stack-tn fp-tn fp) + (maybe-load-stack-tn cfp-tn fp) (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) @@ -591,28 +589,28 @@ default-value-8 ;;; MAYBE-LOAD-STACK-TN. ;;; (define-vop (known-return) - (:args (old-fp :target old-fp-temp) + (:args (ocfp :target ocfp-temp) (return-pc :target return-pc-temp) (vals :more t)) - (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp) + (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp) (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp) - (:temporary (:scs (interior-reg) :type interior) lip) + (:temporary (:scs (interior-reg)) lip) (:move-args :known-return) (:info val-locs) (:ignore val-locs vals) (:vop-var vop) (:generator 6 (trace-table-entry trace-table-function-epilogue) - (maybe-load-stack-tn old-fp-temp old-fp) + (maybe-load-stack-tn ocfp-temp ocfp) (maybe-load-stack-tn return-pc-temp return-pc) - (move csp-tn fp-tn) + (move csp-tn cfp-tn) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (inst addu nsp-tn cur-nfp (bytes-needed-for-non-descriptor-stack-frame)))) (inst addu lip return-pc-temp (- vm:word-bytes vm:other-pointer-type)) (inst j lip) - (move fp-tn old-fp-temp) + (move cfp-tn ocfp-temp) (trace-table-entry trace-table-normal))) @@ -646,7 +644,7 @@ default-value-8 ;;; result values are specified by the Start and Count as in the ;;; unknown-values continuation representation. ;;; -- If :Tail, then do a tail-recursive call. No values are returned. -;;; The Old-Fp and Return-PC are passed as the second and third arguments. +;;; The Ocfp and Return-PC are passed as the second and third arguments. ;;; ;;; In non-tail calls, the pointer to the stack arguments is passed as the last ;;; fixed argument. If Variable is false, then the passing locations are @@ -672,7 +670,7 @@ default-value-8 '(arg-fun :target lexenv)) ,@(when (eq return :tail) - '((old-fp :target old-fp-pass) + '((ocfp :target ocfp-pass) (return-pc :target return-pc-pass))) ,@(unless variable '((args :more t :scs (descriptor-reg))))) @@ -695,11 +693,11 @@ default-value-8 ,@(unless variable '(args))) (:temporary (:sc descriptor-reg - :offset old-fp-offset + :offset ocfp-offset :from (:argument 1) ,@(unless (eq return :fixed) '(:to :eval))) - old-fp-pass) + ocfp-pass) (:temporary (:sc descriptor-reg :offset lra-offset @@ -708,7 +706,7 @@ default-value-8 return-pc-pass) ,@(if named - `((:temporary (:sc descriptor-reg :offset cname-offset + `((:temporary (:sc descriptor-reg :offset fdefn-offset :from (:argument ,(if (eq return :tail) 0 1)) :to :eval) name-pass)) @@ -737,7 +735,7 @@ default-value-8 '((:temporary (:scs (non-descriptor-reg) :from :eval) temp) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) - (:temporary (:scs (interior-reg) :type interior) lip) + (:temporary (:scs (interior-reg)) lip) (:generator ,(+ (if named 5 0) (if variable 19 1) @@ -752,8 +750,8 @@ default-value-8 (remove nil (list :load-nargs ,@(if (eq return :tail) - '((unless (location= old-fp old-fp-pass) - :load-old-fp) + '((unless (location= ocfp ocfp-pass) + :load-ocfp) (unless (location= return-pc return-pc-pass) :load-return-pc) @@ -779,20 +777,20 @@ default-value-8 register-arg-names))) '((inst li nargs-pass (fixnum nargs))))) ,@(if (eq return :tail) - '((:load-old-fp - (sc-case old-fp + '((:load-ocfp + (sc-case ocfp (any-reg - (inst move old-fp-pass old-fp)) + (inst move ocfp-pass ocfp)) (control-stack - (inst lw old-fp-pass fp-tn - (ash (tn-offset old-fp) + (inst lw ocfp-pass cfp-tn + (ash (tn-offset ocfp) vm:word-shift))))) (:load-return-pc (sc-case return-pc (descriptor-reg (inst move return-pc-pass return-pc)) (control-stack - (inst lw return-pc-pass fp-tn + (inst lw return-pc-pass cfp-tn (ash (tn-offset return-pc) vm:word-shift))))) (:frob-nfp @@ -804,13 +802,13 @@ default-value-8 (:frob-nfp (store-stack-tn nfp-save cur-nfp)) (:save-fp - (inst move old-fp-pass fp-tn)) + (inst move ocfp-pass cfp-tn)) (:load-fp ,(if variable - '(move fp-tn new-fp) + '(move cfp-tn new-fp) '(if (> nargs register-arg-count) - (move fp-tn new-fp) - (move fp-tn csp-tn)))))) + (move cfp-tn new-fp) + (move cfp-tn csp-tn)))))) ((nil) (inst nop)))))) @@ -818,7 +816,7 @@ default-value-8 `((sc-case name (descriptor-reg (move name-pass name)) (control-stack - (inst lw name-pass fp-tn + (inst lw name-pass cfp-tn (ash (tn-offset name) vm:word-shift)) (do-next-filler)) (constant @@ -833,7 +831,7 @@ default-value-8 `((sc-case arg-fun (descriptor-reg (move lexenv arg-fun)) (control-stack - (inst lw lexenv fp-tn + (inst lw lexenv cfp-tn (ash (tn-offset arg-fun) vm:word-shift)) (do-next-filler)) (constant @@ -894,12 +892,12 @@ default-value-8 (:args (args-arg :scs (any-reg) :target args) (function-arg :scs (descriptor-reg) :target lexenv) - (old-fp-arg :scs (any-reg) :target old-fp) + (ocfp-arg :scs (any-reg) :target ocfp) (lra-arg :scs (descriptor-reg) :target lra)) (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) - (:temporary (:sc any-reg :offset old-fp-offset :from (:argument 2)) old-fp) + (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) ocfp) (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) (:vop-var vop) @@ -909,7 +907,7 @@ default-value-8 ;; Move these into the passing locations if they are not already there. (move args args-arg) (move lexenv function-arg) - (move old-fp old-fp-arg) + (move ocfp ocfp-arg) (move lra lra-arg) ;; Clear the number stack if anything is there. @@ -928,7 +926,7 @@ default-value-8 ;;; Return a single value using the unknown-values convention. ;;; (define-vop (return-single) - (:args (old-fp :scs (any-reg)) + (:args (ocfp :scs (any-reg)) (return-pc :scs (descriptor-reg)) (value)) (:ignore value) @@ -943,7 +941,7 @@ default-value-8 (bytes-needed-for-non-descriptor-stack-frame)))) ;; Clear the control stack, and restore the frame pointer. (move csp-tn cfp-tn) - (move cfp-tn old-fp) + (move cfp-tn ocfp) ;; Out of here. (lisp-return return-pc lip :offset 2) (trace-table-entry trace-table-normal))) @@ -964,7 +962,7 @@ default-value-8 ;;; (define-vop (return) (:args - (old-fp :scs (any-reg)) + (ocfp :scs (any-reg)) (return-pc :scs (descriptor-reg) :to (:eval 1)) (values :more t)) (:ignore values) @@ -976,8 +974,8 @@ default-value-8 (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4) (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5) (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset old-fp-offset) val-ptr) - (:temporary (:scs (interior-reg) :type interior) lip) + (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) + (:temporary (:scs (interior-reg)) lip) (:vop-var vop) (:generator 6 ;; Clear the number stack. @@ -988,17 +986,17 @@ default-value-8 (bytes-needed-for-non-descriptor-stack-frame)))) (cond ((= nvals 1) ;; Clear the control stack, and restore the frame pointer. - (move csp-tn fp-tn) - (move fp-tn old-fp) + (move csp-tn cfp-tn) + (move cfp-tn ocfp) ;; Out of here. (lisp-return return-pc lip :offset 2)) (t ;; Establish the values pointer and values count. - (move val-ptr fp-tn) + (move val-ptr cfp-tn) (inst li nargs (fixnum nvals)) ;; restore the frame pointer and clear as much of the control ;; stack as possible. - (move fp-tn old-fp) + (move cfp-tn ocfp) (inst addu csp-tn val-ptr (* nvals word-bytes)) ;; pre-default any argument register that need it. (when (< nvals register-arg-count) @@ -1015,17 +1013,17 @@ default-value-8 ;;; (define-vop (return-multiple) (:args - (old-fp-arg :scs (any-reg) :to (:eval 1)) + (ocfp-arg :scs (any-reg) :to (:eval 1)) (lra-arg :scs (descriptor-reg) :to (:eval 1)) (vals-arg :scs (any-reg) :target vals) (nvals-arg :scs (any-reg) :target nvals)) - (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp) + (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp) (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals) (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) (:temporary (:sc descriptor-reg :offset a0-offset) a0) - (:temporary (:scs (interior-reg) :type interior) lip) + (:temporary (:scs (interior-reg)) lip) (:vop-var vop) @@ -1044,13 +1042,13 @@ default-value-8 (inst lw a0 vals-arg) ;; Return with one value. - (move csp-tn fp-tn) - (move fp-tn old-fp-arg) + (move csp-tn cfp-tn) + (move cfp-tn ocfp-arg) (lisp-return lra-arg lip :offset 2) ;; Nope, not the single case. (emit-label not-single) - (move old-fp old-fp-arg) + (move ocfp ocfp-arg) (move lra lra-arg) (move vals vals-arg) (move nvals nvals-arg) @@ -1121,7 +1119,7 @@ default-value-8 ;; Initialize dst to be end of stack. (move dst csp-tn) ;; Initialize src to be end of args. - (inst addu src fp-tn nargs-tn) + (inst addu src cfp-tn nargs-tn) (emit-label loop) ;; *--dst = *--src, --count @@ -1152,9 +1150,7 @@ default-value-8 ;;; More args are stored consequtively on the stack, starting immediately at ;;; the context pointer. The context pointer is not typed, so the lowtag is 0. ;;; -(define-vop (more-arg word-index-ref) - (:variant 0 0) - (:translate %more-arg)) +(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg) ;;; Turn more arg (context, count) into a list. @@ -1165,8 +1161,8 @@ default-value-8 (:arg-types * tagged-num) (:temporary (:scs (any-reg) :from (:argument 0)) context) (:temporary (:scs (any-reg) :from (:argument 1)) count) - (:temporary (:scs (descriptor-reg) :from :eval) temp) - (:temporary (:scs (non-descriptor-reg) :from :eval) ndescr dst) + (:temporary (:scs (descriptor-reg) :from :eval) temp dst) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:results (result :scs (descriptor-reg))) (:translate %listify-rest-args) (:policy :safe) @@ -1181,13 +1177,13 @@ default-value-8 (move result null-tn) ;; We need to do this atomically. - (pseudo-atomic (ndescr) + (pseudo-atomic (pa-flag) ;; Allocate a cons (2 words) for each item. - (inst addu result alloc-tn vm:list-pointer-type) + (inst or result alloc-tn vm:list-pointer-type) (move dst result) - (inst addu alloc-tn alloc-tn count) + (inst sll temp count 1) (inst b enter) - (inst addu alloc-tn alloc-tn count) + (inst addu alloc-tn alloc-tn temp) ;; Store the current cons in the cdr of the previous cons. (emit-label loop) diff --git a/compiler/mips/cell.lisp b/compiler/mips/cell.lisp index 171f5edd37f3c2bbc4c1270b51dcda615b02dd1e..598a1abaa78bbaf4e264cc2df8bde21a0b54c5ab 100644 --- a/compiler/mips/cell.lisp +++ b/compiler/mips/cell.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.58 1992/04/12 20:53:51 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.59 1992/07/28 20:37:24 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.58 1992/04/12 20:53:51 wlott Exp $ -;;; ;;; This file contains the VM definition of various primitive memory access ;;; VOPs for the MIPS. ;;; @@ -89,7 +87,7 @@ (:policy :fast-safe) (:vop-var vop) (:save-p :compute-only) - (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) ;;; With Symbol-Value, we check that the value isn't the trap object. So @@ -112,7 +110,7 @@ (:info target not-p) (:policy :fast-safe) (:temporary (:scs (descriptor-reg)) value) - (:temporary (:type random :scs (non-descriptor-reg)) temp)) + (:temporary (:scs (non-descriptor-reg)) temp)) (define-vop (boundp boundp-frob) (:translate boundp) @@ -240,13 +238,13 @@ ;;;; Closure indexing. -(define-vop (closure-index-ref word-index-ref) - (:variant closure-info-offset function-pointer-type) - (:translate %closure-index-ref)) +(define-full-reffer closure-index-ref * + closure-info-offset function-pointer-type + (descriptor-reg any-reg) * %closure-index-ref) -(define-vop (set-funcallable-instance-info word-index-set) - (:variant funcallable-instance-info-offset function-pointer-type) - (:translate %set-funcallable-instance-info)) +(define-full-reffer set-funcallable-instance-info * + funcallable-instance-info-offset function-pointer-type + (descriptor-reg any-reg) * %set-funcallable-instance-info) @@ -256,12 +254,11 @@ (:policy :fast-safe) (:translate structure-length) (:args (struct :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 4 - (loadw temp struct 0 structure-pointer-type) - (inst srl res temp type-bits))) + (loadw res struct 0 structure-pointer-type) + (inst srl res type-bits))) (define-vop (structure-ref slot-ref) (:variant structure-slots-offset structure-pointer-type) @@ -275,28 +272,18 @@ (:variant structure-slots-offset structure-pointer-type) (:arg-types structure (:constant index) *)) -(define-vop (structure-index-ref word-index-ref) - (:policy :fast-safe) - (:translate structure-ref) - (:variant structure-slots-offset structure-pointer-type) - (:arg-types structure positive-fixnum)) +(define-full-reffer structure-index-ref * structure-slots-offset + structure-pointer-type (descriptor-reg any-reg) * structure-ref) -(define-vop (structure-index-set word-index-set) - (:policy :fast-safe) - (:translate structure-set) - (:variant structure-slots-offset structure-pointer-type) - (:arg-types structure positive-fixnum *)) +(define-full-setter structure-index-set * structure-slots-offset + structure-pointer-type (descriptor-reg any-reg) * structure-set) ;;;; Code object frobbing. -(define-vop (code-header-ref word-index-ref) - (:translate code-header-ref) - (:policy :fast-safe) - (:variant 0 other-pointer-type)) +(define-full-reffer code-header-ref * 0 other-pointer-type + (descriptor-reg any-reg) * code-header-ref) -(define-vop (code-header-set word-index-set) - (:translate code-header-set) - (:policy :fast-safe) - (:variant 0 other-pointer-type)) +(define-full-setter code-header-set * 0 other-pointer-type + (descriptor-reg any-reg) * code-header-set) diff --git a/compiler/mips/debug.lisp b/compiler/mips/debug.lisp index 21b98d1c9773ac2c25571ea8477d99230eb0a95c..08215ccb5d127adfb8f38d15c86775b2e15e1382 100644 --- a/compiler/mips/debug.lisp +++ b/compiler/mips/debug.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/debug.lisp,v 1.12 1992/05/18 19:54:03 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/debug.lisp,v 1.13 1992/07/28 20:37:29 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/debug.lisp,v 1.12 1992/05/18 19:54:03 ram Exp $ -;;; ;;; Compiler support for the new whizzy debugger. ;;; ;;; Written by William Lott. @@ -34,49 +32,63 @@ (:results (res :scs (sap-reg))) (:result-types system-area-pointer) (:generator 1 - (move res fp-tn))) + (move res cfp-tn))) (define-vop (read-control-stack) (:translate stack-ref) (:policy :fast-safe) (:args (object :scs (sap-reg) :target sap) - (offset :scs (any-reg negative-immediate zero immediate))) + (offset :scs (any-reg))) (:arg-types system-area-pointer positive-fixnum) - (:temporary (:scs (sap-reg) :from (:argument 1)) sap) + (:temporary (:scs (sap-reg) :from :eval) sap) (:results (result :scs (descriptor-reg))) (:result-types *) (:generator 5 - (sc-case offset - ((zero) - (inst lw result object 0)) - ((negative-immediate immediate) - (inst lw result object (* (tn-value offset) vm:word-bytes))) - ((any-reg) - (inst addu sap object offset) - (inst lw result sap 0))) + (inst add sap object offset) + (inst lw result sap 0) + (inst nop))) + +(define-vop (read-control-stack-c) + (:translate stack-ref) + (:policy :fast-safe) + (:args (object :scs (sap-reg))) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 14))) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 4 + (inst lw result object (* offset word-bytes)) (inst nop))) (define-vop (write-control-stack) (:translate %set-stack-ref) (:policy :fast-safe) (:args (object :scs (sap-reg) :target sap) - (offset :scs (any-reg negative-immediate zero immediate)) + (offset :scs (any-reg)) (value :scs (descriptor-reg) :target result)) (:arg-types system-area-pointer positive-fixnum *) (:results (result :scs (descriptor-reg))) (:result-types *) (:temporary (:scs (sap-reg) :from (:argument 1)) sap) - (:generator 5 - (sc-case offset - ((zero) - (inst sw value object 0)) - ((negative-immediate immediate) - (inst sw value object (* (tn-value offset) vm:word-bytes))) - ((any-reg) - (inst addu sap object offset) - (inst sw value sap 0))) + (:generator 2 + (inst add sap object offset) + (inst sw sap value 0) (move result value))) +(define-vop (write-control-stack-c) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (value :scs (descriptor-reg) :target result)) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 14)) *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 1 + (inst sw value sap (* offset word-bytes)) + (move result value))) + + (define-vop (code-from-mumble) (:policy :fast-safe) (:args (thing :scs (descriptor-reg))) diff --git a/compiler/mips/float.lisp b/compiler/mips/float.lisp index f11ad37f58e86a910de604e874b625a12a0a7a9e..2bd284a58fce1c2e505ab7c91e711c13d31a36f0 100644 --- a/compiler/mips/float.lisp +++ b/compiler/mips/float.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/float.lisp,v 1.15 1992/07/08 20:56:37 hallgren Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/float.lisp,v 1.16 1992/07/28 20:37:30 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -22,28 +22,28 @@ (define-move-function (load-single 1) (vop x y) ((single-stack) (single-reg)) - (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes)) + (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) word-bytes)) (inst nop)) (define-move-function (store-single 1) (vop x y) ((single-reg) (single-stack)) - (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))) + (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) word-bytes))) (define-move-function (load-double 2) (vop x y) ((double-stack) (double-reg)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset x) vm:word-bytes))) + (offset (* (tn-offset x) word-bytes))) (inst lwc1 y nfp offset) - (inst lwc1-odd y nfp (+ offset vm:word-bytes))) + (inst lwc1-odd y nfp (+ offset word-bytes))) (inst nop)) (define-move-function (store-double 2) (vop x y) ((double-reg) (double-stack)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset y) vm:word-bytes))) + (offset (* (tn-offset y) word-bytes))) (inst swc1 x nfp offset) - (inst swc1-odd x nfp (+ offset vm:word-bytes)))) + (inst swc1-odd x nfp (+ offset word-bytes)))) @@ -70,14 +70,15 @@ (:args (x :to :save)) (:results (y)) (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:variant-vars double-p size type data) (:note "float to pointer coercion") (:generator 13 - (with-fixed-allocation (y ndescr type size) - (inst swc1 x y (- (* data vm:word-bytes) vm:other-pointer-type)) + (with-fixed-allocation (y pa-flag ndescr type size) + (inst swc1 x y (- (* data word-bytes) other-pointer-type)) (when double-p - (inst swc1-odd x y (- (* (1+ data) vm:word-bytes) - vm:other-pointer-type)))))) + (inst swc1-odd x y (- (* (1+ data) word-bytes) + other-pointer-type)))))) (macrolet ((frob (name sc &rest args) `(progn @@ -87,9 +88,9 @@ (:variant ,@args)) (define-move-vop ,name :move (,sc) (descriptor-reg))))) (frob move-from-single single-reg - nil vm:single-float-size vm:single-float-type vm:single-float-value-slot) + nil single-float-size single-float-type single-float-value-slot) (frob move-from-double double-reg - t vm:double-float-size vm:double-float-type vm:double-float-value-slot)) + t double-float-size double-float-type double-float-value-slot)) (macrolet ((frob (name sc double-p value) `(progn @@ -98,15 +99,15 @@ (:results (y :scs (,sc))) (:note "pointer to float coercion") (:generator 2 - (inst lwc1 y x (- (* ,value vm:word-bytes) - vm:other-pointer-type)) + (inst lwc1 y x (- (* ,value word-bytes) + other-pointer-type)) ,@(when double-p - `((inst lwc1-odd y x (- (* (1+ ,value) vm:word-bytes) - vm:other-pointer-type)))) + `((inst lwc1-odd y x (- (* (1+ ,value) word-bytes) + other-pointer-type)))) (inst nop))) (define-move-vop ,name :move (descriptor-reg) (,sc))))) - (frob move-to-single single-reg nil vm:single-float-value-slot) - (frob move-to-double double-reg t vm:double-float-value-slot)) + (frob move-to-single single-reg nil single-float-value-slot) + (frob move-to-double double-reg t double-float-value-slot)) (macrolet ((frob (name sc stack-sc format double-p) @@ -123,11 +124,11 @@ (unless (location= x y) (inst fmove ,format y x))) (,stack-sc - (let ((offset (* (tn-offset y) vm:word-bytes))) + (let ((offset (* (tn-offset y) word-bytes))) (inst swc1 x nfp offset) ,@(when double-p '((inst swc1-odd x nfp - (+ offset vm:word-bytes))))))))) + (+ offset word-bytes))))))))) (define-move-vop ,name :move-argument (,sc descriptor-reg) (,sc))))) (frob move-single-float-argument single-reg single-stack :single nil) @@ -306,6 +307,8 @@ (:results (y :scs (signed-reg))) (:temporary (:from (:argument 0) :sc ,from-sc) temp) (:temporary (:sc non-descriptor-reg) status-save new-status) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) + pa-flag) (:arg-types ,from-type) (:result-types signed-num) (:translate %unary-truncate) @@ -314,7 +317,7 @@ (:vop-var vop) (:save-p :compute-only) (:generator 16 - (pseudo-atomic (status-save) + (pseudo-atomic (pa-flag) (inst cfc1 status-save 31) (inst li new-status (lognot 3)) (inst and new-status status-save) diff --git a/compiler/mips/macros.lisp b/compiler/mips/macros.lisp index 47aedc502381c6e851d75e319ba28be5ab96d4ea..f74c1706ffd88f3ad175b49ad9fb72851252d6cf 100644 --- a/compiler/mips/macros.lisp +++ b/compiler/mips/macros.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.46 1991/11/09 02:37:41 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.47 1992/07/28 20:37:32 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -52,7 +52,7 @@ (defmacro load-symbol (reg symbol) - `(inst add ,reg null-tn (vm:static-symbol-offset ,symbol))) + `(inst add ,reg null-tn (static-symbol-offset ,symbol))) (macrolet ((frob (slot) @@ -71,15 +71,15 @@ (defmacro ,loader (reg symbol) `(progn (inst lw ,reg null-tn - (+ (vm:static-symbol-offset ',symbol) - (ash ,',offset vm:word-shift) - (- vm:other-pointer-type))) + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-type))) (inst nop))) (defmacro ,storer (reg symbol) `(inst sw ,reg null-tn - (+ (vm:static-symbol-offset ',symbol) - (ash ,',offset vm:word-shift) - (- vm:other-pointer-type)))))))) + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-type)))))))) (frob value) (frob function)) @@ -102,9 +102,9 @@ (defmacro lisp-jump (function lip) "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." `(progn - (inst addu ,lip ,function (- (ash vm:function-header-code-offset - vm:word-shift) - vm:function-pointer-type)) + (inst addu ,lip ,function (- (ash function-header-code-offset + word-shift) + function-pointer-type)) (inst j ,lip) (move code-tn ,function))) @@ -112,7 +112,7 @@ "Return to RETURN-PC. LIP is an interior-reg temporary." `(progn (inst addu ,lip ,return-pc - (- (* (1+ ,offset) vm:word-bytes) vm:other-pointer-type)) + (- (* (1+ ,offset) word-bytes) other-pointer-type)) (inst j ,lip) ,(if frob-code `(move code-tn ,return-pc) @@ -121,7 +121,7 @@ (defmacro emit-return-pc (label) "Emit a return-pc header word. LABEL is the label to use for this return-pc." `(progn - (align vm:lowtag-bits) + (align lowtag-bits) (emit-label ,label) (inst lra-header-word))) @@ -139,7 +139,7 @@ (let ((offset (tn-offset stack))) (sc-case stack ((control-stack) - (loadw reg fp-tn offset)))))) + (loadw reg cfp-tn offset)))))) (defmacro store-stack-tn (stack reg) `(let ((stack ,stack) @@ -147,7 +147,7 @@ (let ((offset (tn-offset stack))) (sc-case stack ((control-stack) - (storew reg fp-tn offset)))))) + (storew reg cfp-tn offset)))))) ;;; MAYBE-LOAD-STACK-TN -- Interface @@ -162,23 +162,22 @@ ((any-reg descriptor-reg) (move ,n-reg ,n-stack)) ((control-stack) - (loadw ,n-reg fp-tn (tn-offset ,n-stack)))))))) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) ;;;; Storage allocation: -(defmacro with-fixed-allocation ((result-tn temp-tn type-code size) +(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size) &body body) "Do stuff to allocate an other-pointer object of fixed Size with a single - word header having the specified Type-Code. The result is placed in - Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used - by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably - initializes the object." - `(pseudo-atomic (,temp-tn) - (inst addu ,result-tn alloc-tn vm:other-pointer-type) - (inst addu alloc-tn alloc-tn (vm:pad-data-block ,size)) - (inst li ,temp-tn (logior (ash (1- ,size) vm:type-bits) ,type-code)) - (storew ,temp-tn ,result-tn 0 vm:other-pointer-type) + word header having the specified Type-Code. The result is placed in + Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non- + descriptor temp (which may be randomly used by the body.) The body is + placed inside the PSEUDO-ATOMIC, and presumably initializes the object." + `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) + (inst or ,result-tn alloc-tn other-pointer-type) + (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code)) + (storew ,temp-tn ,result-tn 0 other-pointer-type) ,@body)) @@ -210,227 +209,6 @@ (inst bne temp zero-tn target)))) (inst nop)) - -;;;; Simple Type Checking Macros - -(defmacro simple-test-tag (register temp target not-p tag-type tag-mask) - `(progn - (unless (zerop ,tag-mask) - (inst and ,temp ,register ,tag-mask)) - (inst xor ,temp ,temp ,tag-type) - (if ,not-p - (inst bne ,temp zero-tn ,target) - (inst beq ,temp zero-tn ,target)) - (inst nop))) - -(defmacro simple-test-simple-type (register temp target not-p type-code) - "Emit conditional code that test whether Register holds an object with - the tag specificed if Tag-Type. Temp should be an unboxed register." - (once-only ((n-register register) - (n-temp temp) - (n-target target) - (n-not-p not-p) - (n-type-code type-code)) - `(cond ((< ,n-type-code vm:lowtag-limit) - (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,n-type-code lowtag-mask)) - (t - ;; Nothing clever in this version. Assume other-immediate - ;; type is already in register. - ;; - (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p - ,n-type-code type-mask))))) - -(defmacro test-simple-type (register temp target not-p type-code - &key (lowtag 'vm:other-pointer-type)) - "Emit conditional code that test whether Register holds an object with - the tag specificed if Tag-Type. If the Tag-Type is a type for a heap - object than the register is dereferencd and the heap object is - checked. Temp should be an unboxed register." - (once-only ((n-register register) - (n-temp temp) - (n-target target) - (n-not-p not-p) - (n-type-code type-code)) - `(cond ((< ,n-type-code vm:lowtag-limit) - (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,n-type-code vm:lowtag-mask)) - ((or (= ,n-type-code vm:base-char-type) - (= ,n-type-code vm:unbound-marker-type)) - (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,n-type-code vm:type-mask)) - (t - (let* ((out-label (gen-label)) - (not-other-label (if ,n-not-p ,n-target out-label))) - (simple-test-tag ,n-register ,n-temp not-other-label t - ,lowtag vm:lowtag-mask) - (load-type ,n-temp ,n-register (- ,lowtag)) - (inst nop) - (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p - ,n-type-code 0) - (emit-label out-label)))))) - - -;;;; Hairy Type Checking Macros - -(defun canonicalize-type-codes (type-codes &optional (shift 0)) - (unless type-codes (return-from canonicalize-type-codes nil)) - (let* ((type-codes (sort (remove-duplicates type-codes) #'<)) - (canonical-type-codes nil) - (first-type-code (pop type-codes)) - (last-type-code (ash first-type-code shift)) - (range-start first-type-code) - (range-end nil)) - (dolist (type-code type-codes) - (let ((shifted-type-code (ash type-code shift))) - (cond ((= last-type-code (1- shifted-type-code)) - (setf range-end type-code)) - (t - (push (if range-end (cons range-start range-end) range-start) - canonical-type-codes) - (setf range-start type-code) - (setf range-end nil))) - (setf last-type-code shifted-type-code))) - (push (if range-end (cons range-start range-end) range-start) - canonical-type-codes) - (nreverse canonical-type-codes))) - -(defmacro hairy-test-tag (register temp target not-p tag-types tag-mask) - (let ((in-label (gensym)) - (out-label (gensym))) - (collect ((emit)) - (macrolet ((frob (value) - `(let ((diff (+ (- ,value) last-type-code))) - (unless (zerop diff) - (emit `(inst add ,temp ,temp ,diff)) - (setf last-type-code ,value))))) - (do* ((types tag-types (cdr types)) - (type (car types) (car types)) - (last-type-check-p (null (cdr types)) (null (cdr types))) - (last-type-code 0)) - ((null types)) - (cond ((consp type) - (let ((low (car type)) - (high (cdr type))) - (frob low) - (emit `(inst bltz ,temp ,out-label)) - (frob high) - (cond (last-type-check-p - (emit `(if ,not-p - (inst bgtz ,temp ,target) - (inst blez ,temp ,target)))) - (t - (emit `(inst blez ,temp ,in-label)))))) - (t - (frob type) - (cond (last-type-check-p - (emit `(if ,not-p - (inst bne ,temp zero-tn ,target) - (inst beq ,temp zero-tn ,target)))) - (t - (emit `(inst beq ,temp zero-tn ,in-label)))))))) - `(let* ((drop-through (gen-label)) - (,in-label (if ,not-p drop-through ,target)) - (,out-label (if ,not-p ,target drop-through))) - ,in-label ; squelch possible warning - ,out-label - (unless (zerop ,tag-mask) - (inst and ,temp ,register ,tag-mask)) - ,@(emit) - (inst nop) - (emit-label drop-through))))) - -(defmacro test-hairy-type (register temp target not-p &rest types) - "Test-Hairy-Type Register Temp Target Not-P {Type | (Low-Type High-Type)}+ - - Test whether Register holds a value with one of a specified union of - type codes. All low tag type codes will be checked first. Then the - pointer will be checked to see if it is an other-pointer-type type - pointer in which case it will be dereferenced and the remaining type - codes (the header word type codes) will be checked. All of the - type-code expressions are evaluated at macroexpand time. Temp should - be an unboxed register." - (once-only ((n-register register) - (n-temp temp) - (n-target target) - (n-not-p not-p)) - (unless types (error "Must specify at least one type.")) - ;; - ;; Partition the type codes. - (collect ((low-tag-types) - (header-word-types)) - (dolist (type types) - (let ((type (eval type))) - (cond ((< type vm:lowtag-limit) - (low-tag-types type)) - (t - (header-word-types type))))) - - (let ((low-tag-types (canonicalize-type-codes (low-tag-types))) - (header-word-types (canonicalize-type-codes - (header-word-types) (- (1- lowtag-bits))))) - ;; - ;; Generate code - `(let* ((out-label (gen-label)) - (in-low-tag-label (if ,n-not-p out-label ,n-target)) - (not-other-label (if ,n-not-p ,n-target out-label))) - in-low-tag-label ; may not be used -- squelch warning - not-other-label - ,@(when low-tag-types - (if header-word-types - `((hairy-test-tag ,n-register ,n-temp in-low-tag-label nil - ,low-tag-types vm:lowtag-mask)) - `((hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,low-tag-types vm:lowtag-mask)))) - ,@(when header-word-types - `((simple-test-tag ,n-register ,n-temp not-other-label t - vm:other-pointer-type vm:lowtag-mask) - (load-type ,n-temp ,n-register (- vm:other-pointer-type)) - (inst nop) - (hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,header-word-types 0))) - (emit-label out-label)))))) - -(defmacro simple-test-hairy-type (register temp target not-p &rest types) - "Test-Hairy-Type Register Temp Target Not-P {Type | (Low-Type High-Type)}+ - - Test whether Register holds a value with one of a specified union of - type codes. The type codes must either be all low tag codes or all - header word tag codes. Each separately specified Type is matched, and - also all types between a Low-Type and High-Type pair (inclusive) are - matched. All of the type-code expressions are evaluated at - macroexpand time. Temp should be an unboxed register." - (once-only ((n-register register) - (n-temp temp) - (n-target target) - (n-not-p not-p)) - (unless types (error "Must specify at least one type.")) - ;; - ;; Partition the type codes. - (collect ((low-tag-types) - (header-word-types)) - (dolist (type types) - (cond ((< type vm:lowtag-limit) - (low-tag-types type)) - (t - (header-word-types type)))) - (let ((low-tag-types (low-tag-types)) - (header-word-types (header-word-types))) - (cond ((and low-tag-types header-word-types) - (error "SIMPLE-TEST-HAIRY-TYPE cannot check both low tag ~ - types and other-pointer-type tag types.")) - (low-tag-types - `((hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,(canonicalize-type-codes low-tag-types) - vm:lowtag-mask))) - (header-word-types - `(progn - (inst srl ,n-temp ,n-register vm:lowtag-bits) - (hairy-test-tag ,n-temp ,n-temp ,n-target ,n-not-p - ,(canonicalize-type-codes header-word-types) - vm:type-mask))) - (t - (error "Lost big. Should not be here."))))))) ;;;; Error Code @@ -469,12 +247,12 @@ (inst byte (length ,vector)) (dotimes (i (length ,vector)) (inst byte (aref ,vector i)))) - (align vm:word-shift))))) + (align word-shift))))) (defmacro error-call (vop error-code &rest values) "Cause an error. ERROR-CODE is the error to cause." (cons 'progn - (emit-error-break vop vm:error-trap error-code values))) + (emit-error-break vop error-trap error-code values))) (defmacro cerror-call (vop label error-code &rest values) @@ -482,7 +260,7 @@ LABEL." `(progn (inst b ,label) - ,@(emit-error-break vop vm:cerror-trap error-code values))) + ,@(emit-error-break vop cerror-trap error-code values))) (defmacro generate-error-code (vop error-code &rest values) "Generate-Error-Code Error-code Value* @@ -511,17 +289,180 @@ ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. ;;; -(defmacro pseudo-atomic ((ndescr-temp) &rest forms) - (let ((label (gensym "LABEL-"))) - `(let ((,label (gen-label))) - (inst and flags-tn flags-tn (logxor (ash 1 interrupted-flag) #Xffff)) - (inst or flags-tn flags-tn (ash 1 atomic-flag)) - ,@forms - (inst and flags-tn flags-tn (logxor (ash 1 atomic-flag) #Xffff)) - (inst and ,ndescr-temp flags-tn (ash 1 interrupted-flag)) - (inst beq ,ndescr-temp zero-tn ,label) - (inst nop) - (inst break vm:pending-interrupt-trap) - (emit-label ,label)))) +(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms) + `(progn + (assert (= (tn-offset ,flag-tn) nl4-offset)) + (without-scheduling () + (inst li ,flag-tn (1- ,extra)) + (inst addu alloc-tn 1)) + ,@forms + (without-scheduling () + (inst add alloc-tn ,flag-tn)))) + + +;;;; Memory accessor vop generators + +(deftype load/store-index (scale lowtag min-offset + &optional (max-offset min-offset)) + `(integer ,(- (truncate (+ (ash 1 16) + (* min-offset word-bytes) + (- lowtag)) + scale)) + ,(truncate (- (+ (1- (ash 1 16)) lowtag) + (* max-offset word-bytes)) + scale))) + +(defmacro define-full-reffer (name type offset lowtag scs el-type + &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types ,type tagged-num) + (:temporary (:scs (interior-reg)) lip) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst add lip object index) + (inst lw value lip (- (* ,offset word-bytes) ,lowtag)) + (inst nop))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,word-bytes ,(eval lowtag) + ,(eval offset)))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 4 + (inst lw value object (- (* (+ ,offset index) word-bytes) ,lowtag)) + (inst nop))))) + +(defmacro define-full-setter (name type offset lowtag scs el-type + &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type tagged-num ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 2 + (inst add lip object index) + (inst sw value lip (- (* ,offset word-bytes) ,lowtag)) + (move result value))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs)) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,word-bytes ,(eval lowtag) + ,(eval offset))) + ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 1 + (inst sw value object (- (* (+ ,offset index) word-bytes) ,lowtag)) + (move result value))))) + + +(defmacro define-partial-reffer (name type size signed offset lowtag scs + el-type &optional translate) + (let ((scale (ecase size (:byte 1) (:short 2)))) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:generator 5 + (inst addu lip object index) + ,@(when (eq size :short) + '((inst addu lip index))) + (inst ,(ecase size + (:byte (if signed 'lb 'lbu)) + (:short (if signed 'lh 'lhu))) + value lip (- (* ,offset word-bytes) ,lowtag)) + (inst nop))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,scale + ,(eval lowtag) + ,(eval offset)))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst ,(ecase size + (:byte (if signed 'lb 'lbu)) + (:short (if signed 'lh 'lhu))) + value object + (- (+ (* ,offset word-bytes) (* index ,scale)) ,lowtag)) + (inst nop)))))) + +(defmacro define-partial-setter (name type size offset lowtag scs el-type + &optional translate) + (let ((scale (ecase size (:byte 1) (:short 2)))) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type positive-fixnum ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst addu lip object index) + ,@(when (eq size :short) + '((inst addu lip index))) + (inst ,(ecase size (:byte 'sb) (:short 'sh)) + value lip (- (* ,offset word-bytes) ,lowtag)) + (move result value))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs :target result)) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,scale + ,(eval lowtag) + ,(eval offset))) + ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst ,(ecase size (:byte 'sb) (:short 'sh)) + value object + (- (* ,offset word-bytes) (* index ,scale) ,lowtag)) + (move result value)))))) diff --git a/compiler/mips/memory.lisp b/compiler/mips/memory.lisp index 7550c9a2beab1f7fb919b35dfc82626d253de316..7980d518664528ccf6e27f696a123635ee59e92b 100644 --- a/compiler/mips/memory.lisp +++ b/compiler/mips/memory.lisp @@ -1,4 +1,4 @@ -;;; -*- Package: C; Log: C.Log -*- +;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.12 1991/02/20 15:14:39 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.13 1992/07/28 20:37:35 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.12 1991/02/20 15:14:39 ram Exp $ -;;; ;;; This file contains the MIPS definitions of some general purpose memory ;;; reference VOPs inherited by basic memory reference operations. ;;; @@ -109,62 +107,3 @@ (:generator 4 (storew value object (+ base offset) lowtag))) - - -;;;; Indexed references: - -;;; Define-Indexer -- Internal -;;; -;;; Define some VOPs for indexed memory reference. Unless the index is -;;; constant, we must compute an intermediate result in a boxed temporary, -;;; since the RT doesn't have any indexed addressing modes. This means that GC -;;; has to adjust the "raw" pointer in Index-Temp by observing that Index-Temp -;;; points within Object-Temp. After we are done, we clear Index-Temp so that -;;; we don't raw pointers lying around. -;;; -(defmacro define-indexer (name write-p op shift) - `(define-vop (,name) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg zero immediate negative-immediate)) - ,@(when write-p - '((value :scs (any-reg descriptor-reg) :target result)))) - (:arg-types * tagged-num ,@(when write-p '(*))) - (:temporary (:scs (interior-reg) :type interior) lip) - ,@(unless (zerop shift) - `((:temporary (:scs (non-descriptor-reg) :type random) temp))) - (:results (,(if write-p 'result 'value) - :scs (any-reg descriptor-reg))) - (:result-types *) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 5 - (sc-case index - ((immediate zero negative-immediate) - (inst ,op value object - (- (+ (if (sc-is index zero) - 0 - (ash (tn-value index) (- word-shift ,shift))) - (ash offset word-shift)) - lowtag)) - ,(if write-p - '(move result value) - '(inst nop))) - (t - ,@(if (zerop shift) - `((inst addu lip object index)) - `((inst srl temp index ,shift) - (inst addu lip temp object))) - (inst ,op value lip (- (ash offset word-shift) lowtag)) - ,(if write-p - '(move result value) - '(inst nop))))))) - -(define-indexer word-index-ref nil lw 0) -(define-indexer word-index-set t sw 0) -(define-indexer halfword-index-ref nil lhu 1) -(define-indexer signed-halfword-index-ref nil lh 1) -(define-indexer halfword-index-set t sh 1) -(define-indexer byte-index-ref nil lbu 2) -(define-indexer signed-byte-index-ref nil lb 2) -(define-indexer byte-index-set t sb 2) - diff --git a/compiler/mips/move.lisp b/compiler/mips/move.lisp index 67d72ef3e34672aae27c03802019347125f3c956..cd0c9adcc4ad57ee8763b27aec52f81b214bc7bb 100644 --- a/compiler/mips/move.lisp +++ b/compiler/mips/move.lisp @@ -1,4 +1,4 @@ -;;; -*- Package: C; Log: C.Log -*- +;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.29 1991/11/09 02:37:43 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.30 1992/07/28 20:37:37 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.29 1991/11/09 02:37:43 wlott Exp $ -;;; ;;; This file contains the MIPS VM definition of operand loading/saving and ;;; the Move VOP. ;;; @@ -23,8 +21,7 @@ (define-move-function (load-immediate 1) (vop x y) - ((null unsigned-immediate immediate zero negative-immediate - random-immediate immediate-base-char) + ((null zero immediate) (any-reg descriptor-reg)) (let ((val (tn-value x))) (etypecase val @@ -39,20 +36,20 @@ base-char-type)))))) (define-move-function (load-number 1) (vop x y) - ((unsigned-immediate immediate zero negative-immediate random-immediate) + ((zero immediate) (signed-reg unsigned-reg)) (inst li y (tn-value x))) (define-move-function (load-base-char 1) (vop x y) - ((immediate-base-char) (base-char-reg)) + ((immediate) (base-char-reg)) (inst li y (char-code (tn-value x)))) (define-move-function (load-system-area-pointer 1) (vop x y) - ((immediate-sap) (sap-reg)) + ((immediate) (sap-reg)) (inst li y (sap-int (tn-value x)))) (define-move-function (load-constant 5) (vop x y) - ((constant) (descriptor-reg)) + ((constant) (descriptor-reg any-reg)) (loadw y code-tn (tn-offset x) other-pointer-type)) (define-move-function (load-stack 5) (vop x y) @@ -186,7 +183,7 @@ (inst beq temp done) (inst sra y x 2) - (loadw y x vm:bignum-digits-offset vm:other-pointer-type) + (loadw y x bignum-digits-offset other-pointer-type) (emit-label done)))) ;;; (define-move-vop move-to-word/integer :move @@ -214,6 +211,7 @@ (:args (arg :scs (signed-reg unsigned-reg) :target x)) (:results (y :scs (any-reg descriptor-reg))) (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:note "signed word to integer coercion") (:generator 18 (move x arg) @@ -225,13 +223,9 @@ (inst beq temp done) (inst sll y x 2) - (pseudo-atomic (temp) - (inst addu y alloc-tn vm:other-pointer-type) - (inst addu alloc-tn - (vm:pad-data-block (1+ vm:bignum-digits-offset))) - (inst li temp (logior (ash 1 vm:type-bits) vm:bignum-type)) - (storew temp y 0 vm:other-pointer-type) - (storew x y vm:bignum-digits-offset vm:other-pointer-type)) + (with-fixed-allocation + (y pa-flag temp bignum-type (1+ bignum-digits-offset)) + (storew x y bignum-digits-offset other-pointer-type)) (inst b done) (inst nop) @@ -250,27 +244,24 @@ (:args (arg :scs (signed-reg unsigned-reg) :target x)) (:results (y :scs (any-reg descriptor-reg))) (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:note "unsigned word to integer coercion") (:generator 20 (move x arg) - (let ((done (gen-label)) - (one-word (gen-label))) - (inst sra temp x 29) - (inst beq temp done) - (inst sll y x 2) + (inst sra temp x 29) + (inst beq temp done) + (inst sll y x 2) - (pseudo-atomic (temp) - (inst addu y alloc-tn vm:other-pointer-type) - (inst addu alloc-tn - (vm:pad-data-block (1+ vm:bignum-digits-offset))) - (inst bgez x one-word) - (inst li temp (logior (ash 1 vm:type-bits) vm:bignum-type)) - (inst addu alloc-tn (vm:pad-data-block 1)) - (inst li temp (logior (ash 2 vm:type-bits) vm:bignum-type)) - (emit-label one-word) - (storew temp y 0 vm:other-pointer-type) - (storew x y vm:bignum-digits-offset vm:other-pointer-type)) - (emit-label done)))) + (pseudo-atomic + (pa-flag :extra (pad-data-block (+ bignum-digits-offset 2))) + (inst or y alloc-tn other-pointer-type) + (inst sltu temp x zero-tn) + (inst sll temp type-bits) + (inst addu temp (logior (ash 1 type-bits) bignum-type)) + (storew temp y 0 other-pointer-type) + (storew x y bignum-digits-offset other-pointer-type)) + DONE)) + ;;; (define-move-vop move-from-unsigned :move (unsigned-reg) (descriptor-reg)) diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp index 2438ba3dca16a263198adb02e2b01e023dd39839..38658b63e09542ca49cec7fa2bd4b88b46efac26 100644 --- a/compiler/mips/nlx.lisp +++ b/compiler/mips/nlx.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.17 1992/05/21 23:23:29 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.18 1992/07/28 20:37:40 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.17 1992/05/21 23:23:29 wlott Exp $ -;;; ;;; This file contains the definitions of VOPs used for non-local exit ;;; (throw, lexical exit, etc.) ;;; @@ -101,10 +99,10 @@ (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (non-descriptor-reg)) ndescr) (:generator 22 - (inst addu block fp-tn (* (tn-offset tn) vm:word-bytes)) + (inst addu block cfp-tn (* (tn-offset tn) vm:word-bytes)) (load-symbol-value temp lisp::*current-unwind-protect-block*) (storew temp block vm:unwind-block-current-uwp-slot) - (storew fp-tn block vm:unwind-block-current-cont-slot) + (storew cfp-tn block vm:unwind-block-current-cont-slot) (storew code-tn block vm:unwind-block-current-code-slot) (inst compute-lra-from-code temp code-tn entry-label ndescr) (storew temp block vm:catch-block-entry-pc-slot))) @@ -122,10 +120,10 @@ (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result) (:temporary (:scs (non-descriptor-reg)) ndescr) (:generator 44 - (inst addu result fp-tn (* (tn-offset tn) vm:word-bytes)) + (inst addu result cfp-tn (* (tn-offset tn) vm:word-bytes)) (load-symbol-value temp lisp::*current-unwind-protect-block*) (storew temp result vm:catch-block-current-uwp-slot) - (storew fp-tn result vm:catch-block-current-cont-slot) + (storew cfp-tn result vm:catch-block-current-cont-slot) (storew code-tn result vm:catch-block-current-code-slot) (inst compute-lra-from-code temp code-tn entry-label ndescr) (storew temp result vm:catch-block-entry-pc-slot) @@ -145,7 +143,7 @@ (:args (tn)) (:temporary (:scs (descriptor-reg)) new-uwp) (:generator 7 - (inst addu new-uwp fp-tn (* (tn-offset tn) vm:word-bytes)) + (inst addu new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes)) (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) diff --git a/compiler/mips/parms.lisp b/compiler/mips/parms.lisp index 9a78eca75dfcde4ab33ff857da567e103acae9d4..f34cf6d19c90350369837b0f9671705b52f96886 100644 --- a/compiler/mips/parms.lisp +++ b/compiler/mips/parms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.104 1992/07/08 23:46:14 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.105 1992/07/28 20:37:43 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -23,13 +23,6 @@ (in-package "MIPS") (use-package "C") -(export '(word-bits byte-bits word-shift word-bytes)) - -(export '(float-underflow-trap-bit float-overflow-trap-bit - float-imprecise-trap-bit float-invalid-trap-bit - float-divide-by-zero-trap-bit single-float-trapping-nan-bit - double-float-trapping-nan-bit)) - ;;;; Compiler constants. @@ -40,7 +33,7 @@ (setf (backend-fasl-file-type *target-backend*) "pmaxf") (setf (backend-fasl-file-implementation *target-backend*) pmax-fasl-file-implementation) -(setf (backend-fasl-file-version *target-backend*) 4) +(setf (backend-fasl-file-version *target-backend*) 5) (setf (backend-register-save-penalty *target-backend*) 3) (setf (backend-byte-order *target-backend*) :little-endian) (setf (backend-page-size *target-backend*) 4096) @@ -52,6 +45,23 @@ ;;;; Machine Architecture parameters: +(export '(word-bits byte-bits word-shift word-bytes float-sign-shift + + single-float-bias single-float-exponent-byte + single-float-significand-byte single-float-normal-exponent-min + single-float-normal-exponent-max single-float-hidden-bit + single-float-trapping-nan-bit single-float-digits + + double-float-bias double-float-exponent-byte + double-float-significand-byte double-float-normal-exponent-min + double-float-normal-exponent-max double-float-hidden-bit + double-float-trapping-nan-bit double-float-digits + + float-underflow-trap-bit float-overflow-trap-bit + float-imprecise-trap-bit float-invalid-trap-bit + float-divide-by-zero-trap-bit)) + + (eval-when (compile load eval) (defconstant word-bits 32 @@ -114,6 +124,10 @@ ;;;; Description of the target address space. +(export '(target-read-only-space-start + target-static-space-start + target-dynamic-space-start)) + ;;; Where to put the different spaces. ;;; (defparameter target-read-only-space-start #x01000000) @@ -176,6 +190,7 @@ lisp::maybe-gc kernel::internal-error di::handle-breakpoint + di::handle-function-end-breakpoint lisp::fdefinition-object ;; Free Pointers diff --git a/compiler/mips/print.lisp b/compiler/mips/print.lisp index d31b632d5ba32faf3550510cba915023301580c1..66772e0491fa424bc48dedc9fdd8bedd0a601978 100644 --- a/compiler/mips/print.lisp +++ b/compiler/mips/print.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/print.lisp,v 1.8 1991/07/14 03:49:26 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/print.lisp,v 1.9 1992/07/28 20:37:46 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/print.lisp,v 1.8 1991/07/14 03:49:26 wlott Exp $ -;;; ;;; This file contains temporary printing utilities and similar noise. ;;; ;;; Written by William Lott. @@ -24,28 +22,20 @@ (:args (object :scs (descriptor-reg) :target a0)) (:results (result :scs (descriptor-reg))) (:save-p t) - (:temporary (:sc any-reg :offset 2) v0) + (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0)) + cfunc) (:temporary (:sc descriptor-reg :offset 4 :from (:argument 0)) a0) - (:temporary (:sc any-reg :offset lra-offset) lra) - (:temporary (:sc any-reg :offset code-offset) code) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:vop-var vop) (:generator 0 - (let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn vop))) + (let ((cur-nfp (current-nfp-tn vop))) (move a0 object) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) + (inst li cfunc (make-fixup "debug_print" :foreign)) + (inst jal (make-fixup "call_into_c" :foreign)) (inst addu nsp-tn nsp-tn -16) - (inst compute-lra-from-code lra code lra-label v0) - (inst li v0 (make-fixup "debug_print" :foreign)) - (inst j (make-fixup "call_into_c" :foreign)) - (inst nop) - - (align vm:lowtag-bits) - (emit-label lra-label) - (inst lra-header-word) (inst addu nsp-tn nsp-tn 16) (when cur-nfp (load-stack-tn cur-nfp nfp-save)) - (move result v0)))) + (move result cfunc)))) diff --git a/compiler/mips/sap.lisp b/compiler/mips/sap.lisp index d7f96bbde6ab4336afb95dcbf8402dbdfd68302c..cbb3214953f8e3e3fc53a3927f984fad269afb5d 100644 --- a/compiler/mips/sap.lisp +++ b/compiler/mips/sap.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.25 1992/07/08 20:56:59 hallgren Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.26 1992/07/28 20:37:48 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -27,7 +27,7 @@ (:results (y :scs (sap-reg))) (:note "system area pointer indirection") (:generator 1 - (loadw y x vm:sap-pointer-slot vm:other-pointer-type))) + (loadw y x sap-pointer-slot other-pointer-type))) ;;; (define-move-vop move-to-sap :move @@ -40,16 +40,13 @@ (:args (x :scs (sap-reg) :target sap)) (:temporary (:scs (sap-reg) :from (:argument 0)) sap) (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:results (y :scs (descriptor-reg))) (:note "system area pointer allocation") (:generator 20 (move sap x) - (pseudo-atomic (ndescr) - (inst addu y alloc-tn vm:other-pointer-type) - (inst addu alloc-tn alloc-tn (vm:pad-data-block vm:sap-size)) - (inst li ndescr (logior (ash (1- vm:sap-size) vm:type-bits) vm:sap-type)) - (storew ndescr y 0 vm:other-pointer-type) - (storew sap y vm:sap-pointer-slot vm:other-pointer-type)))) + (with-fixed-allocation (y pa-flag ndescr sap-type sap-size) + (storew sap y sap-pointer-slot other-pointer-type)))) ;;; (define-move-vop move-from-sap :move (sap-reg) (descriptor-reg)) @@ -188,7 +185,7 @@ '((inst lwc1 result sap 0))) (:double '((inst lwc1 result sap 0) - (inst lwc1-odd result sap vm:word-bytes)))) + (inst lwc1-odd result sap word-bytes)))) (inst nop))) (define-vop (,ref-name-c) (:translate ,ref-name) @@ -219,7 +216,7 @@ '((inst lwc1 result object offset))) (:double '((inst lwc1 result object offset) - (inst lwc1-odd result object (+ offset vm:word-bytes))))) + (inst lwc1-odd result object (+ offset word-bytes))))) (inst nop))) (define-vop (,set-name) (:translate ,set-name) @@ -249,7 +246,7 @@ (inst fmove :single result value)))) (:double '((inst swc1 value sap 0) - (inst swc1-odd value sap vm:word-bytes) + (inst swc1-odd value sap word-bytes) (unless (location= result value) (inst fmove :double result value))))))) (define-vop (,set-name-c) @@ -284,7 +281,7 @@ (inst fmove :single result value)))) (:double '((inst swc1 value object offset) - (inst swc1-odd value object (+ offset vm:word-bytes)) + (inst swc1-odd value object (+ offset word-bytes)) (unless (location= result value) (inst fmove :double result value)))))))))) @@ -320,5 +317,5 @@ (:result-types system-area-pointer) (:generator 2 (inst addu sap vector - (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type)))) + (- (* vector-data-offset word-bytes) other-pointer-type)))) diff --git a/compiler/mips/static-fn.lisp b/compiler/mips/static-fn.lisp index 1b3ebdbe75467e3f10d0b7cf14436d5bb08a2a87..03da29f8e5dafb86b2cc73a9fd95c401cb1724f4 100644 --- a/compiler/mips/static-fn.lisp +++ b/compiler/mips/static-fn.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.17 1992/05/21 02:12:53 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.18 1992/07/28 20:37:50 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.17 1992/05/21 02:12:53 wlott Exp $ -;;; ;;; This file contains the VOPs and macro magic necessary to call static ;;; functions. ;;; @@ -30,9 +28,9 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (descriptor-reg)) move-temp) (:temporary (:sc descriptor-reg :offset lra-offset) lra) - (:temporary (:scs (interior-reg) :type interior) lip) + (:temporary (:scs (interior-reg)) lip) (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) old-fp) + (:temporary (:sc any-reg :offset ocfp-offset) ocfp) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) @@ -94,7 +92,7 @@ (inst lw lip null-tn (static-function-offset symbol)) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) - (inst move old-fp cfp-tn) + (inst move ocfp cfp-tn) (inst compute-lra-from-code lra code-tn lra-label temp) (note-this-location vop :call-site) (inst j lip) diff --git a/compiler/mips/subprim.lisp b/compiler/mips/subprim.lisp index 1494b18d25740c1ae4c7b827daca585fd9c417d3..5b0449e5815af291a35af25216f3920450aabf4f 100644 --- a/compiler/mips/subprim.lisp +++ b/compiler/mips/subprim.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/subprim.lisp,v 1.20 1991/02/20 15:15:14 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/subprim.lisp,v 1.21 1992/07/28 20:37:52 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/subprim.lisp,v 1.20 1991/02/20 15:15:14 ram Exp $ -;;; ;;; Linkage information for standard static functions, and random vops. ;;; ;;; Written by William Lott. @@ -28,7 +26,7 @@ (:args (object :scs (descriptor-reg) :target ptr)) (:arg-types list) (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) - (:temporary (:scs (non-descriptor-reg) :type random) temp) + (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result) count) (:results (result :scs (any-reg descriptor-reg))) @@ -36,27 +34,28 @@ (:vop-var vop) (:save-p :compute-only) (:generator 50 - (let ((done (gen-label)) - (loop (gen-label)) - (not-list (generate-cerror-code vop object-not-list-error object))) - (move ptr object) - (move count zero-tn) - - (emit-label loop) - - (inst beq ptr null-tn done) - (inst nop) - - (simple-test-simple-type ptr temp not-list t vm:list-pointer-type) - - (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) - (inst addu count count (fixnum 1)) - (simple-test-simple-type ptr temp loop nil vm:list-pointer-type) - - (cerror-call vop done object-not-list-error ptr) - - (emit-label done) - (move result count)))) + (move ptr object) + (move count zero-tn) + + LOOP + + (inst beq ptr null-tn done) + (inst nop) + + (inst and temp ptr lowtag-mask) + (inst xor temp list-pointer-type) + (inst bne temp zero-tn not-list) + (inst nop) + + (loadw ptr ptr cons-cdr-slot list-pointer-type) + (inst b loop) + (inst addu count count (fixnum 1)) + + NOT-LIST + (cerror-call vop done object-not-list-error ptr) + + DONE + (move result count))) (define-static-function length (object) :translate length) diff --git a/compiler/mips/system.lisp b/compiler/mips/system.lisp index ec98033b6c1b9f882df5beaecdc64709c7a64a4f..6978f4b0db6f34b58231a52636e4413bb4114210 100644 --- a/compiler/mips/system.lisp +++ b/compiler/mips/system.lisp @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.45 1992/04/21 04:22:20 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.46 1992/07/28 20:37:54 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.45 1992/04/21 04:22:20 wlott Exp $ -;;; ;;; MIPS VM definitions of various system hacking operations. ;;; ;;; Written by Rob MacLachlan @@ -28,7 +26,7 @@ (:args (x :scs (sap-reg)) (y :scs (sap-reg))) (:arg-types system-area-pointer system-area-pointer) - (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) temp) (:conditional) (:info target not-p) (:policy :fast-safe) @@ -58,7 +56,7 @@ (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 1 - (inst and result object vm:lowtag-mask))) + (inst and result object lowtag-mask))) (define-vop (get-type) (:translate get-type) @@ -68,43 +66,40 @@ (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 6 - (let ((other-ptr (gen-label)) - (lowtag-only (gen-label)) - (function-ptr (gen-label)) - (done (gen-label))) - ;; Pick off objects with headers. - (simple-test-simple-type object ndescr other-ptr - nil vm:other-pointer-type) - (simple-test-simple-type object ndescr function-ptr - nil vm:function-pointer-type) - - ;; Pick off fixnums. - (inst and result object 3) - (inst beq result done) - - ;; Pick off structure and list pointers. - (inst and result object 1) - (inst bne result lowtag-only) - (inst nop) + ;; Pick off objects with headers. + (inst and ndescr object lowtag-mask) + (inst xor ndescr other-pointer-type) + (inst beq ndescr other-ptr) + (inst xor ndescr (logxor other-pointer-type function-pointer-type)) + (inst beq ndescr function-ptr) + + ;; Pick off fixnums. + (inst and result object 3) + (inst beq result done) + + ;; Pick off structure and list pointers. + (inst and result object 1) + (inst bne result lowtag-only) + (inst nop) ;; Must be an other immediate. - (inst b done) - (inst and result object vm:type-mask) + (inst b done) + (inst and result object type-mask) - (emit-label function-ptr) - (load-type result object (- vm:function-pointer-type)) - (inst b done) - (inst nop) + FUNCTION-PTR + (load-type result object (- function-pointer-type)) + (inst b done) + (inst nop) - (emit-label lowtag-only) - (inst b done) - (inst and result object lowtag-mask) + LOWTAG-ONLY + (inst b done) + (inst and result object lowtag-mask) - (emit-label other-ptr) - (load-type result object (- vm:other-pointer-type)) - (inst nop) + OTHER-PTR + (load-type result object (- other-pointer-type)) + (inst nop) - (emit-label done)))) + DONE)) (define-vop (function-subtype) (:translate function-subtype) @@ -113,7 +108,7 @@ (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 6 - (load-type result function (- vm:function-pointer-type)) + (load-type result function (- function-pointer-type)) (inst nop))) (define-vop (set-function-subtype) @@ -136,8 +131,8 @@ (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 6 - (loadw res x 0 vm:other-pointer-type) - (inst srl res res vm:type-bits))) + (loadw res x 0 other-pointer-type) + (inst srl res res type-bits))) (define-vop (get-closure-length) (:translate get-closure-length) @@ -146,8 +141,8 @@ (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 6 - (loadw res x 0 vm:function-pointer-type) - (inst srl res res vm:type-bits))) + (loadw res x 0 function-pointer-type) + (inst srl res res type-bits))) (define-vop (set-header-data) (:translate set-header-data) @@ -156,18 +151,18 @@ (data :scs (any-reg immediate zero))) (:arg-types * positive-fixnum) (:results (res :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :type random) t1 t2) + (:temporary (:scs (non-descriptor-reg)) t1 t2) (:generator 6 - (loadw t1 x 0 vm:other-pointer-type) - (inst and t1 vm:type-mask) + (loadw t1 x 0 other-pointer-type) + (inst and t1 type-mask) (sc-case data (any-reg - (inst sll t2 data (- vm:type-bits 2)) + (inst sll t2 data (- type-bits 2)) (inst or t1 t2)) (immediate - (inst or t1 (ash (tn-value data) vm:type-bits))) + (inst or t1 (ash (tn-value data) type-bits))) (zero)) - (storew t1 x 0 vm:other-pointer-type) + (storew t1 x 0 other-pointer-type) (move res x))) (define-vop (c::make-fixnum) @@ -182,18 +177,18 @@ (define-vop (c::make-other-immediate-type) (:args (val :scs (any-reg descriptor-reg)) - (type :scs (any-reg descriptor-reg immediate unsigned-immediate) + (type :scs (any-reg descriptor-reg immediate) :target temp)) (:results (res :scs (any-reg descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) temp) (:generator 2 (sc-case type - ((immediate unsigned-immediate) - (inst sll temp val vm:type-bits) + ((immediate) + (inst sll temp val type-bits) (inst or res temp (tn-value type))) (t (inst sra temp type 2) - (inst sll res val (- vm:type-bits 2)) + (inst sll res val (- type-bits 2)) (inst or res res temp))))) @@ -234,10 +229,10 @@ (:results (sap :scs (sap-reg))) (:result-types system-area-pointer) (:generator 10 - (loadw ndescr code 0 vm:other-pointer-type) - (inst srl ndescr vm:type-bits) - (inst sll ndescr vm:word-shift) - (inst subu ndescr vm:other-pointer-type) + (loadw ndescr code 0 other-pointer-type) + (inst srl ndescr type-bits) + (inst sll ndescr word-shift) + (inst subu ndescr other-pointer-type) (inst addu sap code ndescr))) (define-vop (compute-function) @@ -247,11 +242,11 @@ (:results (func :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) ndescr) (:generator 10 - (loadw ndescr code 0 vm:other-pointer-type) - (inst srl ndescr vm:type-bits) - (inst sll ndescr vm:word-shift) + (loadw ndescr code 0 other-pointer-type) + (inst srl ndescr type-bits) + (inst sll ndescr word-shift) (inst addu ndescr offset) - (inst addu ndescr (- vm:function-pointer-type vm:other-pointer-type)) + (inst addu ndescr (- function-pointer-type other-pointer-type)) (inst addu func code ndescr))) @@ -263,12 +258,12 @@ (:policy :fast-safe) (:translate unix::do-pending-interrupt) (:generator 1 - (inst break vm:pending-interrupt-trap))) + (inst break pending-interrupt-trap))) (define-vop (halt) (:generator 1 - (inst break vm:halt-trap))) + (inst break halt-trap))) ;;;; Dynamic vop count collection support diff --git a/compiler/mips/type-vops.lisp b/compiler/mips/type-vops.lisp index a55cc50de2674fc64237a097e2fca97e1ff53a31..272baefa2426cab5fee82fc2b96f4793418d8e64 100644 --- a/compiler/mips/type-vops.lisp +++ b/compiler/mips/type-vops.lisp @@ -7,278 +7,393 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.33 1992/03/11 21:26:52 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.34 1992/07/28 20:37:57 wlott Exp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the VM definition of type testing and checking VOPs -;;; for the RT. +;;; for the MIPS. ;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted for the MIPS R2000 by Christopher Hoover. +;;; Written by William Lott +;;; Earlier versions by Rob MacLachlan and Christopher Hoover. ;;; (in-package "MIPS") - -;;;; Simple type checking and testing: -;;; -;;; These types are represented by a single type code, so are easily -;;; open-coded as non-shifting type test. - -(define-vop (check-simple-type) - (:args - (value :target result - :scs (any-reg descriptor-reg))) - (:results - (result :scs (any-reg descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:save-p :compute-only)) - -(define-vop (simple-type-predicate) - (:args - (value :scs (any-reg descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:variant-vars type-code) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:generator 4 - (test-simple-type value temp target not-p type-code))) - -(macrolet ((frob (pred-name check-name ptype type-code error-code) - (let ((cost (if (< (eval type-code) vm:lowtag-limit) 4 9))) - `(progn - (define-vop (,pred-name simple-type-predicate) - (:variant ,type-code) - (:variant-cost ,cost) - (:translate ,pred-name)) - (define-vop (,check-name check-simple-type) - (:generator ,cost - (let ((err-lab - (generate-error-code vop ,error-code value))) - (test-simple-type value temp err-lab t ,type-code) - (move result value)))) - (primitive-type-vop ,check-name (:check) ,ptype))))) - - (frob functionp check-function function - vm:function-pointer-type object-not-function-error) - - (frob listp check-list list - vm:list-pointer-type object-not-list-error) - - (frob structurep check-structure structure - vm:structure-pointer-type object-not-structure-error) - - (frob bignump check-bigunm bignum - vm:bignum-type object-not-bignum-error) - (frob ratiop check-ratio ratio - vm:ratio-type object-not-ratio-error) - - (frob complexp check-complex complex - vm:complex-type object-not-complex-error) - - (frob single-float-p check-single-float single-float - vm:single-float-type object-not-single-float-error) + +;;;; Test generation utilities. + +(eval-when (compile eval) + +(defparameter immediate-types + (list unbound-marker-type base-char-type)) + +(defparameter function-header-types + (list funcallable-instance-header-type closure-header-type + byte-code-function-type byte-code-closure-type + function-header-type closure-function-header-type)) + +(defun canonicalize-headers (headers) + (collect ((results)) + (let ((start nil) + (prev nil) + (delta (- other-immediate-1-type other-immediate-0-type))) + (flet ((emit-test () + (results (if (= start prev) + start + (cons start prev))))) + (dolist (header (sort headers #'<)) + (cond ((null start) + (setf start header) + (setf prev header)) + ((= header (+ prev delta)) + (setf prev header)) + (t + (emit-test) + (setf start header) + (setf prev header)))) + (emit-test))) + (results))) + +(defmacro test-type (value temp target not-p &rest type-codes) + ;; Determine what interesting combinations we need to test for. + (let* ((type-codes (mapcar #'eval type-codes)) + (fixnump (and (member even-fixnum-type type-codes) + (member odd-fixnum-type type-codes) + t)) + (lowtags (remove lowtag-limit type-codes :test #'<)) + (extended (remove lowtag-limit type-codes :test #'>)) + (immediates (intersection extended immediate-types :test #'eql)) + (headers (set-difference extended immediate-types :test #'eql)) + (function-p (if (intersection headers function-header-types) + (if (subsetp headers function-header-types) + t + (error "Can't test for mix of function subtypes ~ + and normal header types.")) + nil))) + (unless type-codes + (error "Must supply at least on type for test-type.")) + (cond + (fixnump + (when (remove-if #'(lambda (x) + (or (= x even-fixnum-type) + (= x odd-fixnum-type))) + lowtags) + (error "Can't mix fixnum testing with other lowtags.")) + (when function-p + (error "Can't mix fixnum testing with function subtype testing.")) + (when immediates + (error "Can't mix fixnum testing with other immediates.")) + (if headers + `(%test-fixnum-and-headers ,value ,temp ,target ,not-p + ',(canonicalize-headers headers)) + `(%test-fixnum ,value ,temp ,target ,not-p))) + (immediates + (when headers + (error "Can't mix testing of immediates with testing of headers.")) + (when lowtags + (error "Can't mix testing of immediates with testing of lowtags.")) + (when (cdr immediates) + (error "Can't test multiple immediates at the same time.")) + `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates))) + (lowtags + (when (cdr lowtags) + (error "Can't test multiple lowtags at the same time.")) + (if headers + `(%test-lowtag-and-headers + ,value ,temp ,target ,not-p ,(car lowtags) + ,function-p ',(canonicalize-headers headers)) + `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags)))) + (headers + `(%test-headers ,value ,temp ,target ,not-p ,function-p + ',(canonicalize-headers headers))) + (t + (error "Nothing to test?"))))) + +); eval-when (compile eval) + +(defun %test-fixnum (value temp target not-p) + (assemble () + (inst and temp value 3) + (if not-p + (inst bne temp zero-tn target) + (inst beq temp zero-tn target)) + (inst nop))) - (frob double-float-p check-double-float double-float - vm:double-float-type object-not-double-float-error) +(defun %test-fixnum-and-headers (value temp target not-p headers) + (let ((drop-through (gen-label))) + (assemble () + (inst and temp value 3) + (inst beq temp zero-tn (if not-p drop-through target))) + (%test-headers value temp target not-p nil headers drop-through))) + +(defun %test-immediate (value temp target not-p immediate) + (assemble () + (inst and temp value 255) + (inst xor temp immediate) + (if not-p + (inst bne temp zero-tn target) + (inst beq temp zero-tn target)) + (inst nop))) - (frob simple-string-p check-simple-string simple-string - vm:simple-string-type object-not-simple-string-error) +(defun %test-lowtag (value temp target not-p lowtag &optional skip-nop) + (assemble () + (inst and temp value lowtag-mask) + (inst xor temp lowtag) + (if not-p + (inst bne temp zero-tn target) + (inst beq temp zero-tn target)) + (unless skip-nop + (inst nop)))) + +(defun %test-lowtag-and-headers (value temp target not-p lowtag + function-p headers) + (let ((drop-through (gen-label))) + (%test-lowtag value temp (if not-p drop-through target) nil lowtag t) + (%test-headers value temp target not-p function-p headers drop-through))) + +(defun %test-headers (value temp target not-p function-p headers + &optional (drop-through (gen-label))) + (let ((lowtag (if function-p function-header-type other-pointer-type))) + (multiple-value-bind + (when-true when-false) + ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when + ;; we know it's true and when we know it's false respectively. + (if not-p + (values drop-through target) + (values target drop-through)) + (assemble () + (%test-lowtag value temp when-false t lowtag) + (load-type temp value (- lowtag)) + (inst nop) + (let ((delta 0)) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (inst subu temp (- header delta)) + (setf delta header) + (if last + (if not-p + (inst bne temp zero-tn target) + (inst beq temp zero-tn target)) + (inst beq temp zero-tn when-true))) + (t + (let ((start (car header)) + (end (cdr header))) + (unless (= start bignum-type) + (inst subu temp (- start delta)) + (setf delta start) + (inst bltz temp when-false)) + (inst subu temp (- end delta)) + (setf delta end) + (if last + (if not-p + (inst bgtz temp target) + (inst blez temp target)) + (inst blez temp when-true)))))))) + (inst nop) + (emit-label drop-through))))) - (frob simple-bit-vector-p check-simple-bit-vector simple-bit-vector - vm:simple-bit-vector-type object-not-simple-bit-vector-error) - (frob simple-vector-p check-simple-vector simple-vector - vm:simple-vector-type object-not-simple-vector-error) + +;;;; Type checking and testing: - (frob simple-array-unsigned-byte-2-p check-simple-array-unsigned-byte-2 - simple-array-unsigned-byte-2 vm:simple-array-unsigned-byte-2-type - object-not-simple-array-unsigned-byte-2-error) +(define-vop (check-type) + (:args (value :target result :scs (any-reg descriptor-reg))) + (:results (result :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp) + (:vop-var vop) + (:save-p :compute-only)) - (frob simple-array-unsigned-byte-4-p check-simple-array-unsigned-byte-4 - simple-array-unsigned-byte-4 vm:simple-array-unsigned-byte-4-type - object-not-simple-array-unsigned-byte-4-error) +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe)) + +(eval-when (compile eval) + +(defun cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) lowtag-limit) 7 2))) + +(defmacro def-type-vops (pred-name check-name ptype error-code + &rest type-codes) + (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) + `(progn + ,@(when pred-name + `((define-vop (,pred-name type-predicate) + (:translate ,pred-name) + (:generator ,cost + (test-type value temp target not-p ,@type-codes))))) + ,@(when check-name + `((define-vop (,check-name check-type) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ,error-code value))) + (test-type value temp err-lab t ,@type-codes) + (move result value)))))) + ,@(when ptype + `((primitive-type-vop ,check-name (:check) ,ptype)))))) - (frob simple-array-unsigned-byte-8-p check-simple-array-unsigned-byte-8 - simple-array-unsigned-byte-8 vm:simple-array-unsigned-byte-8-type - object-not-simple-array-unsigned-byte-8-error) +); eval-when (compile eval) - (frob simple-array-unsigned-byte-16-p check-simple-array-unsigned-byte-16 - simple-array-unsigned-byte-16 vm:simple-array-unsigned-byte-16-type - object-not-simple-array-unsigned-byte-16-error) +(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error + even-fixnum-type odd-fixnum-type) - (frob simple-array-unsigned-byte-32-p check-simple-array-unsigned-byte-32 - simple-array-unsigned-byte-32 vm:simple-array-unsigned-byte-32-type - object-not-simple-array-unsigned-byte-32-error) +(def-type-vops functionp check-function function + object-not-function-error function-pointer-type) - (frob simple-array-single-float-p check-simple-array-single-float - simple-array-single-float vm:simple-array-single-float-type - object-not-simple-array-single-float-error) +(def-type-vops listp check-list list object-not-list-error + list-pointer-type) - (frob simple-array-double-float-p check-simple-array-double-float - simple-array-double-float vm:simple-array-double-float-type - object-not-simple-array-double-float-error) +(def-type-vops structurep check-structure structure object-not-structure-error + structure-pointer-type) - (frob base-char-p check-base-char base-char - vm:base-char-type object-not-base-char-error) +(def-type-vops bignump check-bigunm bignum + object-not-bignum-error bignum-type) - (frob system-area-pointer-p check-system-area-pointer system-area-pointer - vm:sap-type object-not-sap-error) +(def-type-vops ratiop check-ratio ratio + object-not-ratio-error ratio-type) - (frob weak-pointer-p check-weak-pointer weak-pointer - vm:weak-pointer-type object-not-weak-pointer-error)) +(def-type-vops complexp check-complex complex + object-not-complex-error complex-type) -(define-vop (funcallable-instance-p simple-type-predicate) - (:translate funcallable-instance-p) - (:variant-vars) - (:generator 4 - (test-simple-type value temp target not-p - vm:funcallable-instance-header-type - :lowtag vm:function-pointer-type))) +(def-type-vops single-float-p check-single-float single-float + object-not-single-float-error single-float-type) + +(def-type-vops double-float-p check-double-float double-float + object-not-double-float-error double-float-type) + +(def-type-vops simple-string-p check-simple-string simple-string + object-not-simple-string-error simple-string-type) + +(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector + object-not-simple-bit-vector-error simple-bit-vector-type) + +(def-type-vops simple-vector-p check-simple-vector simple-vector + object-not-simple-vector-error simple-vector-type) + +(def-type-vops simple-array-unsigned-byte-2-p + check-simple-array-unsigned-byte-2 + simple-array-unsigned-byte-2 + object-not-simple-array-unsigned-byte-2-error + simple-array-unsigned-byte-2-type) + +(def-type-vops simple-array-unsigned-byte-4-p + check-simple-array-unsigned-byte-4 + simple-array-unsigned-byte-4 + object-not-simple-array-unsigned-byte-4-error + simple-array-unsigned-byte-4-type) + +(def-type-vops simple-array-unsigned-byte-8-p + check-simple-array-unsigned-byte-8 + simple-array-unsigned-byte-8 + object-not-simple-array-unsigned-byte-8-error + simple-array-unsigned-byte-8-type) + +(def-type-vops simple-array-unsigned-byte-16-p + check-simple-array-unsigned-byte-16 + simple-array-unsigned-byte-16 + object-not-simple-array-unsigned-byte-16-error + simple-array-unsigned-byte-16-type) + +(def-type-vops simple-array-unsigned-byte-32-p + check-simple-array-unsigned-byte-32 + simple-array-unsigned-byte-32 + object-not-simple-array-unsigned-byte-32-error + simple-array-unsigned-byte-32-type) + +(def-type-vops simple-array-single-float-p check-simple-array-single-float + simple-array-single-float object-not-simple-array-single-float-error + simple-array-single-float-type) + +(def-type-vops simple-array-double-float-p check-simple-array-double-float + simple-array-double-float object-not-simple-array-double-float-error + simple-array-double-float-type) + +(def-type-vops base-char-p check-base-char base-char + object-not-base-char-error base-char-type) + +(def-type-vops system-area-pointer-p check-system-area-pointer + system-area-pointer object-not-sap-error sap-type) + +(def-type-vops weak-pointer-p check-weak-pointer weak-pointer + object-not-weak-pointer-error weak-pointer-type) + +(def-type-vops scavenger-hook-p nil nil nil + 0) + +(def-type-vops code-component-p nil nil nil + code-header-type) -(define-vop (code-component-p simple-type-predicate) - (:variant code-header-type) - (:variant-cost 9) - (:translate code-component-p)) +(def-type-vops lra-p nil nil nil + return-pc-header-type) -(define-vop (lra-p simple-type-predicate) - (:variant return-pc-header-type) - (:variant-cost 9) - (:translate lra-p)) +(def-type-vops fdefn-p nil nil nil + fdefn-type) -(define-vop (fdefn-p simple-type-predicate) - (:variant fdefn-type) - (:variant-cost 9) - (:translate fdefn-p)) +(def-type-vops funcallable-instance-p nil nil nil + funcallable-instance-header-type) -(define-vop (scavenger-hook-p simple-type-predicate) - (:variant 0) - (:variant-cost 9) - (:translate scavenger-hook-p)) +(def-type-vops array-header-p nil nil nil + simple-array-type complex-string-type complex-bit-vector-type + complex-vector-type complex-array-type) +(def-type-vops nil check-function-or-symbol nil + object-not-function-or-symbol-error + function-pointer-type symbol-header-type) +(def-type-vops stringp check-string nil object-not-string-error + simple-string-type complex-string-type) -;;; Slightly tenser versions for FIXNUM's -;;; -(define-vop (check-fixnum check-simple-type) - (:generator 3 - (let ((err-lab (generate-error-code vop object-not-fixnum-error value))) - (inst and temp value #x3) - (inst bne temp zero-tn err-lab) - (move result value t)))) - -(primitive-type-vop check-fixnum (:check) fixnum) - -(define-vop (fixnump simple-type-predicate) - (:ignore type-code) - (:translate ext:fixnump) - (:generator 3 - (inst and temp value #x3) - (if not-p - (inst bne temp zero-tn target) - (inst beq temp zero-tn target)) - (inst nop))) +(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error + simple-bit-vector-type complex-bit-vector-type) - -;;;; Hairy type tests: -;;; -;;; These types are represented by a union of type codes. -;;; +(def-type-vops vectorp check-vector nil object-not-vector-error + simple-string-type simple-bit-vector-type simple-vector-type + simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type + simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type + simple-array-unsigned-byte-32-type simple-array-single-float-type + simple-array-double-float-type complex-string-type + complex-bit-vector-type complex-vector-type) -(define-vop (hairy-type-predicate) - (:args - (obj :scs (any-reg descriptor-reg) - :target temp)) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:type random :scs (non-descriptor-reg)) temp)) - -(define-vop (check-hairy-type) - (:args - (obj :scs (any-reg descriptor-reg) - :target res)) - (:results - (res :scs (any-reg descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:save-p :compute-only)) +(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error + simple-array-type simple-string-type simple-bit-vector-type + simple-vector-type simple-array-unsigned-byte-2-type + simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type + simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type + simple-array-single-float-type simple-array-double-float-type) -(macrolet ((frob (pred-name check-name error-code &rest types) - (let ((cost (* (+ (length types) - (count-if #'consp types)) - 4))) - `(progn - ,@(when pred-name - `((define-vop (,pred-name hairy-type-predicate) - (:translate ,pred-name) - (:generator ,cost - (test-hairy-type obj temp target not-p ,@types))))) - - ,@(when check-name - `((define-vop (,check-name check-hairy-type) - (:generator ,cost - (let ((err-lab (generate-error-code vop - ,error-code - obj))) - (test-hairy-type obj temp err-lab t ,@types)) - (move res obj))))))))) - - (frob array-header-p nil nil - vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type - vm:complex-vector-type vm:complex-array-type) - - (frob stringp check-string object-not-string-error - vm:simple-string-type vm:complex-string-type) - - (frob bit-vector-p check-bit-vector object-not-bit-vector-error - vm:simple-bit-vector-type vm:complex-bit-vector-type) - - (frob vectorp check-vector object-not-vector-error - vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type - vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type - vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type - vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type - vm:simple-array-double-float-type vm:complex-string-type - vm:complex-bit-vector-type vm:complex-vector-type) - - (frob simple-array-p check-simple-array object-not-simple-array-error - vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type - vm:simple-vector-type vm:simple-array-unsigned-byte-2-type - vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type - vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type - vm:simple-array-single-float-type vm:simple-array-double-float-type) - - (frob arrayp check-array object-not-array-error - vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type - vm:simple-vector-type vm:simple-array-unsigned-byte-2-type - vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type - vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type - vm:simple-array-single-float-type vm:simple-array-double-float-type - vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type - vm:complex-array-type) - - (frob numberp check-number object-not-number-error - vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type - vm:single-float-type vm:double-float-type vm:complex-type) - - (frob rationalp check-rational object-not-rational-error - vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) - - (frob floatp check-float object-not-float-error - vm:single-float-type vm:double-float-type) - - (frob realp check-real object-not-real-error - vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type - vm:single-float-type vm:double-float-type) - - ;; ### May want to make this more tense. - (frob integerp check-integer object-not-integer-error - vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)) +(def-type-vops arrayp check-array nil object-not-array-error + simple-array-type simple-string-type simple-bit-vector-type + simple-vector-type simple-array-unsigned-byte-2-type + simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type + simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type + simple-array-single-float-type simple-array-double-float-type + complex-string-type complex-bit-vector-type complex-vector-type + complex-array-type) + +(def-type-vops numberp check-number nil object-not-number-error + even-fixnum-type odd-fixnum-type bignum-type ratio-type + single-float-type double-float-type complex-type) + +(def-type-vops rationalp check-rational nil object-not-rational-error + even-fixnum-type odd-fixnum-type ratio-type bignum-type) + +(def-type-vops integerp check-integer nil object-not-integer-error + even-fixnum-type odd-fixnum-type bignum-type) + +(def-type-vops floatp check-float nil object-not-float-error + single-float-type double-float-type) + +(def-type-vops realp check-real nil object-not-real-error + even-fixnum-type odd-fixnum-type ratio-type bignum-type + single-float-type double-float-type) ;;;; Other integer ranges. @@ -286,146 +401,101 @@ ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with ;;; exactly one digit. -(define-vop (signed-byte-32-p hairy-type-predicate) - (:translate signed-byte-32-p) - (:generator 45 - (let ((not-target (gen-label))) - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - (inst and temp obj #x3) - (inst beq temp zero-tn yep) - (test-simple-type obj temp nope t vm:bignum-type) - (loadw temp obj 0 vm:other-pointer-type) - (inst srl temp temp (1+ vm:type-bits)) - (if not-p - (inst bne temp zero-tn target) - (inst beq temp zero-tn target)) - (inst nop) - (emit-label not-target))))) - -(define-vop (check-signed-byte-32 check-hairy-type) - (:generator 45 - (let ((nope (generate-error-code vop object-not-signed-byte-32-error obj)) - (yep (gen-label))) - (inst and temp obj #x3) +(defun signed-byte-32-test (value temp not-p target not-target) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (assemble () + (inst and temp value 3) (inst beq temp zero-tn yep) - (test-simple-type obj temp nope t vm:bignum-type) - (loadw temp obj 0 vm:other-pointer-type) - (inst srl temp temp (1+ vm:type-bits)) + (inst and temp value lowtag-mask) + (inst xor temp other-pointer-type) (inst bne temp zero-tn nope) (inst nop) - (emit-label yep) - (move res obj)))) + (loadw temp value 0 other-pointer-type) + (inst xor temp (+ (ash 1 type-bits) bignum-type)) + (if not-p + (inst bne temp zero-tn target) + (inst beq temp zero-tn target)) + (inst nop))) + (undefined-value)) + +(define-vop (signed-byte-32-p type-predicate) + (:translate signed-byte-32-p) + (:generator 45 + (signed-byte-32-test value temp not-p target not-target) + NOT-TARGET)) +(define-vop (check-signed-byte-32 check-type) + (:generator 45 + (let ((loose (generate-error-code vop object-not-signed-byte-32-error + value))) + (signed-byte-32-test value temp t loose okay)) + OKAY + (move result value))) ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a ;;; bignum with exactly one positive digit, or a bignum with exactly two digits ;;; and the second digit all zeros. -(define-vop (unsigned-byte-32-p hairy-type-predicate) - (:translate unsigned-byte-32-p) - (:generator 45 - (let ((not-target (gen-label)) - (single-word (gen-label)) - (fixnum (gen-label))) - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - ;; Is it a fixnum? - (inst and temp obj #x3) - (inst beq temp zero-tn fixnum) - ;; If not, is it a bignum? - (test-simple-type obj temp nope t vm:bignum-type) - ;; Get the number of digits. - (loadw temp obj 0 vm:other-pointer-type) - (inst srl temp temp vm:type-bits) - ;; Is it one? - (inst addu temp -1) - (inst beq temp single-word) - ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst addu temp -1) - (inst bne temp nope) - ;; Get the second digit. - (loadw temp obj (1+ vm:bignum-digits-offset) vm:other-pointer-type) - ;; All zeros, its an (unsigned-byte 32). - (inst beq temp yep) - (inst nop) - ;; Otherwise, it isn't. - (inst b nope) - (inst nop) - - (emit-label single-word) - ;; Get the single digit. - (loadw temp obj vm:bignum-digits-offset vm:other-pointer-type) - ;; positive implies (unsigned-byte 32). - (inst bgez temp yep) - (inst nop) - ;; Otherwise, nope. - (inst b nope) - (inst nop) - - (emit-label fixnum) - ;; positive fixnums are (unsigned-byte 32). - (if not-p - (inst bltz obj target) - (inst bgez obj target)) - (inst nop) - - (emit-label not-target))))) - -(define-vop (check-unsigned-byte-32 check-hairy-type) - (:generator 45 - (let ((nope - (generate-error-code vop object-not-unsigned-byte-32-error obj)) - (yep (gen-label)) - (fixnum (gen-label)) - (single-word (gen-label))) +(defun unsigned-byte-32-test (value temp not-p target not-target) + (let ((nope (if not-p target not-target))) + (assemble () ;; Is it a fixnum? - (inst and temp obj #x3) + (inst and temp value 3) (inst beq temp zero-tn fixnum) - ;; If not, is it a bignum? - (test-simple-type obj temp nope t vm:bignum-type) - ;; Get the number of digits. - (loadw temp obj 0 vm:other-pointer-type) - (inst srl temp temp vm:type-bits) + (inst move temp value) + + ;; If not, is it an other pointer? + (inst and temp value lowtag-mask) + (inst xor temp other-pointer-type) + (inst bne temp zero-tn nope) + (inst nop) + ;; Get the header. + (loadw temp value 0 other-pointer-type) ;; Is it one? - (inst addu temp -1) - (inst beq temp single-word) + (inst xor temp (+ (ash 1 type-bits) bignum-type)) + (inst beq temp zero-tn single-word) + (inst nop) ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst addu temp -1) - (inst bne temp nope) + (inst xor temp (logxor (+ (ash 1 type-bits) bignum-type) + (+ (ash 2 type-bits) bignum-type))) + (inst bne temp zero-tn nope) ;; Get the second digit. - (loadw temp obj (1+ vm:bignum-digits-offset) vm:other-pointer-type) + (loadw temp value (1+ bignum-digits-offset) other-pointer-type) ;; All zeros, its an (unsigned-byte 32). - (inst beq temp yep) + (if not-p + (inst beq temp zero-tn target) + (inst bne temp zero-tn target)) (inst nop) - ;; Otherwise, it isn't. - (inst b nope) - (inst nop) - - (emit-label single-word) + + SINGLE-WORD ;; Get the single digit. - (loadw temp obj vm:bignum-digits-offset vm:other-pointer-type) + (loadw temp value bignum-digits-offset other-pointer-type) + ;; positive implies (unsigned-byte 32). - (inst bgez temp yep) - (inst nop) - ;; Otherwise, nope. - (inst b nope) - (inst nop) - - (emit-label fixnum) - ;; positive fixnums are (unsigned-byte 32). - (inst bltz obj nope) - (inst nop) - - (emit-label yep) - (move res obj)))) + FIXNUM + (if not-p + (inst bltz temp target) + (inst bgez temp target)) + (inst nop))) + (undefined-value)) + +(define-vop (unsigned-byte-32-p type-predicate) + (:translate unsigned-byte-32-p) + (:generator 45 + (unsigned-byte-32-test value temp not-p target not-target) + NOT-TARGET)) +(define-vop (check-unsigned-byte-32 check-type) + (:generator 45 + (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error + value))) + (unsigned-byte-32-test value temp t loose okay)) + OKAY + (move result value))) @@ -434,44 +504,31 @@ ;;; symbolp (or symbol (eq nil)) ;;; consp (and list (not (eq nil))) -(define-vop (list-symbol-predicate) - (:args - (obj :scs (any-reg descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:type random :scs (non-descriptor-reg)) temp))) - -(define-vop (check-list-symbol check-hairy-type) - (:temporary (:type random :scs (non-descriptor-reg)) temp)) - - -(macrolet ((frob (pred-name check-name error-code &rest body) - `(progn - (define-vop (,pred-name list-symbol-predicate) - (:translate ,pred-name) - (:generator 8 - ,@body)) - (define-vop (,check-name check-list-symbol) - (:generator 8 - (let ((target (generate-error-code vop ,error-code obj)) - (not-p t)) - ,@body - (move res obj))))))) - - (frob symbolp check-symbol object-not-symbol-error - (let* ((drop-thru (gen-label)) - (is-symbol-label (if not-p drop-thru target))) - (inst beq obj null-tn is-symbol-label) - (inst nop) - (test-simple-type obj temp target not-p vm:symbol-header-type) - (emit-label drop-thru))) - - (frob consp check-cons object-not-cons-error - (let* ((drop-thru (gen-label)) - (is-not-cons-label (if not-p target drop-thru))) - (inst beq obj null-tn is-not-cons-label) - (inst nop) - (test-simple-type obj temp target not-p vm:list-pointer-type) - (emit-label drop-thru)))) - +(define-vop (symbolp type-predicate) + (:translate symbolp) + (:generator 12 + (inst beq value null-tn (if not-p drop-thru target)) + (test-type value temp target not-p symbol-header-type) + DROP-THRU)) + +(define-vop (check-symbol check-type) + (:generator 12 + (inst beq value null-tn drop-thru) + (let ((error (generate-error-code vop object-not-symbol-error value))) + (test-type value temp error t symbol-header-type)) + DROP-THRU + (move result value))) + +(define-vop (consp type-predicate) + (:translate consp) + (:generator 8 + (inst beq value null-tn (if not-p target drop-thru)) + (test-type value temp target not-p list-pointer-type) + DROP-THRU)) + +(define-vop (check-cons check-type) + (:generator 8 + (let ((error (generate-error-code vop object-not-cons-error value))) + (inst beq value null-tn error) + (test-type value temp error t list-pointer-type)) + (move result value))) diff --git a/compiler/mips/values.lisp b/compiler/mips/values.lisp index 4c14ec45c9c4f44c265d97321b92a92d6b7207d0..4e16808ebeb996886dc5cadd7cd3840b07190df2 100644 --- a/compiler/mips/values.lisp +++ b/compiler/mips/values.lisp @@ -1,4 +1,4 @@ -;;; -*- Package: C; Log: C.Log -*- +;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.12 1991/02/20 15:15:29 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.13 1992/07/28 20:38:01 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.12 1991/02/20 15:15:29 ram Exp $ -;;; ;;; This file contains the implementation of unknown-values VOPs. ;;; ;;; Written by Rob MacLachlan @@ -50,7 +48,7 @@ start-temp) (:generator 20 (move start-temp csp-tn) - (inst addu csp-tn csp-tn (* nvals vm:word-bytes)) + (inst addu csp-tn csp-tn (* nvals word-bytes)) (do ((val vals (tn-ref-across val)) (i 0 (1+ i))) ((null val)) @@ -76,25 +74,25 @@ (count :scs (any-reg))) (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (:temporary (:scs (non-descriptor-reg)) ndescr) (:vop-var vop) (:save-p :compute-only) (:generator 0 - (let ((loop (gen-label)) - (done (gen-label))) - - (move list arg) - (move start csp-tn) - - (emit-label loop) - (inst beq list null-tn done) - (loadw temp list vm:cons-car-slot vm:list-pointer-type) - (loadw list list vm:cons-cdr-slot vm:list-pointer-type) - (inst addu csp-tn csp-tn vm:word-bytes) - (storew temp csp-tn -1) - (test-simple-type list ndescr loop nil vm:list-pointer-type) - (error-call vop bogus-argument-to-values-list-error list) - - (emit-label done) - (inst subu count csp-tn start)))) + (move list arg) + (move start csp-tn) + + LOOP + (inst beq list null-tn done) + (loadw temp list cons-car-slot list-pointer-type) + (loadw list list cons-cdr-slot list-pointer-type) + (inst addu csp-tn csp-tn word-bytes) + (storew temp csp-tn -1) + (inst and ndescr list lowtag-mask) + (inst xor ndescr list-pointer-type) + (inst beq ndescr zero-tn loop) + (inst nop) + (error-call vop bogus-argument-to-values-list-error list) + + DONE + (inst subu count csp-tn start))) diff --git a/compiler/mips/vm.lisp b/compiler/mips/vm.lisp index 9d62a129cff62599d60231e8c1b251abdedec0e0..ca895258dc63645d274423234853f4ade5db3e5e 100644 --- a/compiler/mips/vm.lisp +++ b/compiler/mips/vm.lisp @@ -1,4 +1,4 @@ -;;; -*- Package: MIPS; Log: C.Log -*- +;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.45 1992/05/21 02:10:32 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.46 1992/07/28 20:38:03 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.45 1992/05/21 02:10:32 wlott Exp $ -;;; ;;; This file contains the VM definition for the MIPS R2000 and the new ;;; object format. ;;; @@ -27,9 +25,8 @@ (defmacro defreg (name offset) (let ((offset-sym (symbolicate name "-OFFSET"))) - `(progn - (eval-when (compile eval load) - (defconstant ,offset-sym ,offset)) + `(eval-when (compile eval load) + (defconstant ,offset-sym ,offset) (setf (svref *register-names* ,offset-sym) ,(symbol-name name))))) (defmacro defregset (name &rest regs) @@ -39,12 +36,16 @@ ) +(eval-when (compile eval load) + (defvar *register-names* (make-array 32 :initial-element nil)) +); eval-when + (defreg zero 0) (defreg nl3 1) -(defreg nl4 2) -(defreg flags 3) +(defreg cfunc 2) +(defreg nl4 3) (defreg nl0 4) ; First C argument reg. (defreg nl1 5) (defreg nl2 6) @@ -55,41 +56,37 @@ (defreg a3 11) (defreg a4 12) (defreg a5 13) -(defreg cname 14) +(defreg fdefn 14) (defreg lexenv 15) +;; First saved reg (defreg nfp 16) (defreg ocfp 17) -(eval-when (compile load eval) - (defconstant old-fp-offset 17)) ; for backwards compatibility (defreg lra 18) (defreg l0 19) (defreg null 20) (defreg bsp 21) (defreg cfp 22) -(eval-when (compile load eval) - (defconstant fp-offset 22)) ; for backwards compatibility (defreg csp 23) (defreg l1 24) (defreg alloc 25) -(defreg l2 28) (defreg nsp 29) (defreg code 30) (defreg lip 31) (defregset non-descriptor-regs - nl0 nl1 nl2 nl3 nl4 nargs) + nl0 nl1 nl2 nl3 nl4 cfunc nargs) (defregset descriptor-regs - a0 a1 a2 a3 a4 a5 cname lexenv nfp ocfp lra l0 l1 l2) + a0 a1 a2 a3 a4 a5 fdefn lexenv nfp ocfp lra l0 l1) (defregset register-arg-offsets a0 a1 a2 a3 a4 a5) (defregset reserve-descriptor-regs - cname lexenv) + fdefn lexenv) (defregset reserve-non-descriptor-regs - nl3 nl4) + nl4 cfunc) ;;;; SB and SC definition: @@ -124,41 +121,13 @@ (define-storage-classes - ;; Non-immediate contstants in the constant pool + ;; Non-immediate constants in the constant pool (constant constant) - - ;; Immediate numeric constants. - ;; - ;; zero = (integer 0 0) - ;; - ;; negative-immediate = (integer #x-1FFF #-x0001) - ;; The funny lower bound guarantees that the negation of an immediate - ;; is still an immediate. - ;; - ;; immediate = (integer 0 #x1FFE) - ;; The funny upper bound guarantees that (1+ immediate) will fit in - ;; 16 bits. - ;; - ;; unsigned-immediate = (integer #x1FFF #x3FFE) - ;; The funny upper bound guarantees that (1+ immediate) will fit in - ;; 16 bits. - ;; + ;; Immediate constant. + (null immediate-constant) (zero immediate-constant) - (negative-immediate immediate-constant) (immediate immediate-constant) - (unsigned-immediate immediate-constant) - - ;; Immediate SCs for things other than numbers. - (null immediate-constant) - (immediate-base-char immediate-constant) - (immediate-sap immediate-constant) - - ;; Anything else that can be computed faster than loaded that doesn't fit in - ;; any of the above immediate SCs. - (random-immediate immediate-constant) - - ;; **** The stacks. @@ -174,7 +143,6 @@ (double-stack non-descriptor-stack :element-size 2) ; double floats. - ;; **** Things that can go in the integer registers. ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing @@ -184,8 +152,7 @@ :locations #.(append non-descriptor-regs descriptor-regs) :reserve-locations #.(append reserve-non-descriptor-regs reserve-descriptor-regs) - :constant-scs (negative-immediate zero immediate unsigned-immediate - immediate-base-char random-immediate) + :constant-scs (constant zero immediate) :save-p t :alternate-scs (control-stack)) @@ -193,7 +160,7 @@ (descriptor-reg registers :locations #.descriptor-regs :reserve-locations #.reserve-descriptor-regs - :constant-scs (constant null random-immediate) + :constant-scs (constant null immediate) :save-p t :alternate-scs (control-stack)) @@ -201,7 +168,7 @@ (base-char-reg registers :locations #.non-descriptor-regs :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (immediate-base-char) + :constant-scs (immediate) :save-p t :alternate-scs (base-char-stack)) @@ -209,7 +176,7 @@ (sap-reg registers :locations #.non-descriptor-regs :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (immediate-sap) + :constant-scs (immediate) :save-p t :alternate-scs (sap-stack)) @@ -217,14 +184,13 @@ (signed-reg registers :locations #.non-descriptor-regs :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (negative-immediate zero immediate unsigned-immediate - random-immediate) + :constant-scs (zero immediate) :save-p t :alternate-scs (signed-stack)) (unsigned-reg registers :locations #.non-descriptor-regs :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (zero immediate unsigned-immediate random-immediate) + :constant-scs (zero immediate) :save-p t :alternate-scs (unsigned-stack)) @@ -280,20 +246,17 @@ (defregtn zero any-reg) (defregtn lip interior-reg) (defregtn code descriptor-reg) -(defregtn flags non-descriptor-reg) (defregtn alloc any-reg) (defregtn null descriptor-reg) (defregtn nargs any-reg) -(defregtn cname descriptor-reg) +(defregtn fdefn descriptor-reg) (defregtn lexenv descriptor-reg) (defregtn bsp any-reg) (defregtn csp any-reg) (defregtn cfp any-reg) (defregtn ocfp any-reg) -(defregtn fp any-reg) ; for backwards compatibility -(defregtn old-fp any-reg) ; for backwards compatibility (defregtn nsp any-reg) (defregtn nfp any-reg) @@ -311,29 +274,16 @@ (sc-number-or-lose 'zero *backend*)) (null (sc-number-or-lose 'null *backend*)) - ((integer #x-1FFF #x-0001) - (sc-number-or-lose 'negative-immediate *backend*)) - ((integer 0 #x1FFE) - (sc-number-or-lose 'immediate *backend*)) - ((integer #x1FFF #x3FFE) - (sc-number-or-lose 'unsigned-immediate *backend*)) (symbol (if (vm:static-symbol-p value) - (sc-number-or-lose 'random-immediate *backend*) + (sc-number-or-lose 'immediate *backend*) nil)) - (#-new-compiler (signed-byte 30) - #+new-compiler fixnum - (sc-number-or-lose 'random-immediate *backend*)) - #+new-compiler + ((signed-byte 30) + (sc-number-or-lose 'immediate *backend*)) (system-area-pointer - (sc-number-or-lose 'immediate-sap *backend*)) + (sc-number-or-lose 'immediate *backend*)) (character - #-new-compiler - (if (string-char-p value) - (sc-number-or-lose 'immediate-base-char *backend*) - nil) - #+new-compiler - (sc-number-or-lose 'immediate-base-char *backend*)))) + (sc-number-or-lose 'immediate *backend*)))) ;;;; Function Call Parameters @@ -348,7 +298,6 @@ ;;; Offsets of special stack frame locations (defconstant ocfp-save-offset 0) -(defconstant old-fp-save-offset 0) ; for backwards compatablility. (defconstant lra-save-offset 1) (defconstant nfp-save-offset 2)