diff --git a/compiler/rt/alloc.lisp b/compiler/rt/alloc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..db33c1efbc143884e641ddc87e93bc82ce13338f --- /dev/null +++ b/compiler/rt/alloc.lisp @@ -0,0 +1,135 @@ +;;; -*- Package: rt -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/alloc.lisp,v 1.1 1991/02/18 15:07:30 chiles Exp $ +;;; +;;; Allocation VOPs for the IBM RT port. +;;; +;;; Written by William Lott. +;;; Converted by Bill Chiles. +;;; + +(in-package "RT") + + + +;;;; LIST and LIST* + +(define-vop (list-or-list*) + (:args (things :more t)) + (:temporary (:scs (descriptor-reg) :type list) ptr) + (: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 (:scs (word-pointer-reg)) alloc) + (:info num) + (:results (result :scs (descriptor-reg))) + (:variant-vars star) + (:policy :safe) + (:generator 0 + (cond ((zerop num) + (move result null-tn)) + ((and star (= num 1)) + (move result (tn-ref-tn things))) + (t + (macrolet + ((store-car (tn list &optional (slot cons-car-slot)) + `(let ((reg + (sc-case ,tn + ((any-reg descriptor-reg) ,tn) + (null null-tn) + (control-stack + (load-stack-tn temp ,tn) + temp)))) + (storew reg ,list ,slot list-pointer-type)))) + (let ((cons-cells (if star (1- num) num))) + (pseudo-atomic (ndescr) + (load-symbol-value alloc *allocation-pointer*) + (inst cal res alloc list-pointer-type) + (inst cal alloc alloc (* (pad-data-block cons-size) + cons-cells)) + (store-symbol-value alloc *allocation-pointer*) + (move ptr res) + (dotimes (i (1- cons-cells)) + (store-car (tn-ref-tn things) ptr) + (setf things (tn-ref-across things)) + (inst cal ptr ptr (pad-data-block cons-size)) + (storew ptr ptr + (- 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 cons-cdr-slot)) + (t + (storew null-tn ptr + cons-cdr-slot list-pointer-type))) + (assert (null (tn-ref-across things))) + (move result res)))))))) + +(define-vop (list list-or-list*) + (:variant nil)) + +(define-vop (list* list-or-list*) + (:variant t)) + + + +;;;; Special purpose inline allocators. + +(define-vop (allocate-code-object) + (:args (boxed-arg :scs (any-reg)) + (unboxed-arg :scs (any-reg) :target unboxed)) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:scs (word-pointer-reg)) alloc) + (:temporary (:scs (any-reg) :from (:argument 0)) boxed) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:generator 100 + (inst li ndescr (lognot lowtag-mask)) + (inst cal boxed boxed-arg (fixnum (1+ code-constants-offset))) + (inst n boxed ndescr) + (move unboxed unboxed-arg) + (inst sr unboxed word-shift) + (inst a unboxed lowtag-mask) + (inst n unboxed ndescr) + (pseudo-atomic (ndescr) + (load-symbol-value alloc *allocation-pointer*) + (inst cal result alloc other-pointer-type) + (inst cas alloc boxed alloc) + (inst cas alloc unboxed alloc) + (store-symbol-value alloc *allocation-pointer*) + (move ndescr boxed) + (inst sl ndescr (- type-bits word-shift)) + (inst o 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-symbol) + (:args (name :scs (descriptor-reg) :to :eval)) + (:temporary (:scs (sap-reg)) temp) + (:temporary (:scs (word-pointer-reg)) alloc) + (:results (result :scs (descriptor-reg) :from :argument)) + (:policy :fast-safe) + (:translate make-symbol) + (:generator 37 + (with-fixed-allocation (result temp alloc symbol-header-type symbol-size) + (inst li temp unbound-marker-type) + (storew temp result symbol-value-slot other-pointer-type) + (storew temp result symbol-function-slot other-pointer-type) + (storew temp result symbol-setf-function-slot other-pointer-type) + (inst cai temp (make-fixup "undefined_tramp" :foreign)) + (storew temp result symbol-raw-function-addr-slot + other-pointer-type) + (storew null-tn result symbol-plist-slot other-pointer-type) + (storew name result symbol-name-slot other-pointer-type) + (storew null-tn result symbol-package-slot other-pointer-type)))) diff --git a/compiler/rt/arith.lisp b/compiler/rt/arith.lisp new file mode 100644 index 0000000000000000000000000000000000000000..f6d6d9e37fad79acf0d7fce550b00da97ed67cd0 --- /dev/null +++ b/compiler/rt/arith.lisp @@ -0,0 +1,849 @@ +;;; -*- Package: C; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/arith.lisp,v 1.1 1991/02/18 15:07:33 chiles Exp $ +;;; +;;; This file contains the VM definition arithmetic VOPs for the IBM RT. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by Bill Chiles. +;;; + +(in-package "RT") + + + +;;;; Unary operations. + +(define-vop (fixnum-unop) + (:args (x :scs (any-reg))) + (:results (res :scs (any-reg))) + (:note "inline fixnum arithmetic") + (:arg-types tagged-num) + (:result-types tagged-num) + (:policy :fast-safe)) + +(define-vop (signed-unop) + (:args (x :scs (signed-reg))) + (:results (res :scs (signed-reg))) + (:note "inline (signed-byte 32) arithmetic") + (:arg-types signed-num) + (:result-types signed-num) + (:policy :fast-safe)) + +(define-vop (fast-negate/fixnum fixnum-unop) + (:translate %negate) + (:generator 1 + (inst neg res x))) + +(define-vop (fast-negate/signed signed-unop) + (:translate %negate) + (:generator 2 + (inst neg res x))) + +(define-vop (fast-lognot/fixnum fixnum-unop) + (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target res) + temp) + (:translate lognot) + (:generator 2 + (inst li temp (fixnum -1)) + (inst x temp x) + (move res temp))) + +(define-vop (fast-lognot/signed signed-unop) + (:translate lognot) + (:generator 1 + (inst not res x))) + + + +;;;; Binary fixnum operations (+, -, LOGIOR, LOGAND, LOGXOR). + +;;; Assume that any constant operand is the second arg... + +(define-vop (fast-fixnum-binop) + (:args (x :target r :scs (any-reg)) + (y :scs (any-reg immediate) :to :save)) + (:arg-types tagged-num tagged-num) + (:temporary (:scs (any-reg)) temp) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-unsigned-binop) + (:args (x :target r :scs (unsigned-reg)) + (y :scs (unsigned-reg immediate) :to :save)) + (:arg-types unsigned-num unsigned-num) + (:temporary (:scs (any-reg)) temp) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-signed-binop) + (:args (x :target r :scs (signed-reg)) + (y :scs (signed-reg immediate) :to :save)) + (:arg-types signed-num signed-num) + (:temporary (:scs (any-reg)) temp) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:effects) + (:affected) + (:policy :fast-safe)) + +(eval-when (compile eval) + +(defmacro define-binop (translate cost op &body imm-body) + `(progn + (define-vop (,(intern (concatenate 'simple-string + "FAST-" + (string translate) + "/FIXNUM=>FIXNUM")) + fast-fixnum-binop) + (:translate ,translate) + (:generator ,cost + (sc-case y + (any-reg + (move r x) + (inst ,op r y)) + (immediate + (let ((value (fixnum (tn-value y)))) + ,@imm-body))))) + (define-vop (,(intern (concatenate 'simple-string + "FAST-" + (string translate) + "/SIGNED=>SIGNED")) + fast-signed-binop) + (:translate ,translate) + (:generator ,(1+ cost) + (sc-case y + (signed-reg + (move r x) + (inst ,op r y)) + (immediate + (let ((value (tn-value y))) + ,@imm-body))))) + (define-vop (,(intern (concatenate 'simple-string + "FAST-" + (string translate) + "/UNSIGNED=>UNSIGNED")) + fast-unsigned-binop) + (:translate ,translate) + (:generator ,(1+ cost) + (sc-case y + (unsigned-reg + (move r x) + (inst ,op r y)) + (immediate + (let ((value (tn-value y))) + ,@imm-body))))))) + +) ;EVAL-WHEN + + +(define-binop + 3 a + (cond ((typep value '(signed-byte 16)) + (inst a r x value)) + (t + (move r x) + (inst li temp value) + (inst a r temp)))) + +(define-binop - 3 s + (cond ((typep value '(signed-byte 16)) + (inst s r x value)) + (t + (move r x) + (inst li temp value) + (inst s r temp)))) + +(define-binop logior 2 o + (let ((low (ldb (byte 16 0) value)) + (high (ldb (byte 16 16) value))) + (cond ((zerop value) + (move r x)) + ((zerop low) + (inst oiu r x high)) + ((zerop high) + (inst oil r x low)) + (t + (inst oil r x low) + (inst oiu r r high))))) + +(define-binop logxor 2 x + (let ((low (ldb (byte 16 0) value)) + (high (ldb (byte 16 16) value))) + (cond ((zerop value) + (move r x)) + ((zerop low) + (inst xiu r x high)) + ((zerop high) + (inst xil r x low)) + (t + (inst xil r x low) + (inst xiu r r high))))) + +(define-binop logand 1 n + (let ((low (ldb (byte 16 0) value)) + (high (ldb (byte 16 16) value))) + (cond ((= low high #xFFFF) + (move r x)) + ((zerop low) + (inst niuz r x high)) + ((= low #xFFFF) + (inst niuo r x high)) + ((zerop high) + (inst nilz r x low)) + ((= high #xFFFF) + (inst nilo r x low)) + (t + (inst nilo r x low) + (inst niuo r r high))))) + + + +;;;; Binary fixnum operations. + +(define-vop (fast-ash) + (:note "inline ASH") + (:args (number :scs (signed-reg unsigned-reg) :to :save) + (amount :scs (signed-reg immediate))) + (:arg-types (:or signed-num unsigned-num) signed-num) + (:results (result :scs (signed-reg unsigned-reg))) + (:result-types (:or signed-num unsigned-num)) + (:translate ash) + (:policy :fast-safe) + (:temporary (:sc non-descriptor-reg) ndesc) + (:generator 12 + (sc-case amount + (signed-reg + (let ((positive (gen-label)) + (done (gen-label))) + (inst c amount 0) + (inst bncx :lt positive) + (inst neg ndesc amount) + (inst c ndesc 32) + ;; If less than 32, goto done while shifting. + (inst bcx :lt done) + (sc-case number + (signed-reg + (move result number) + (inst sar result ndesc)) + (unsigned-reg + (move result number) + (inst sr result ndesc))) + ;; 32 or greater case. + (inst bx done) + (sc-case number + (signed-reg + (move result number) + (inst sar result 31)) + (unsigned-reg + (move result number) + (inst sr result 31))) + + (emit-label positive) + ;; The result-type assures us that this shift will not overflow. + (move result number) + (inst sl result amount) + + (emit-label done))) + + (immediate + (let ((amount (tn-value amount))) + (cond ((minusp amount) + (sc-case number + (unsigned-reg + (move result number) + (inst sr result (min (- amount) 31))) + (t + (move result number) + (inst sar result (min (- amount) 31))))) + (t + (move result number) + (inst sl result (min amount 31))))))))) + + +;;; SIGNED-BYTE-32-LEN -- VOP. +;;; +;;; Common Lisp INTEGER-LENGTH. Due to the definition of this operation, +;;; (integer-length x) == (integer-length (lognot x)). +;;; We determine the result by using the RT's count-leading-zeros which only +;;; works on the zeros in the lower half of a word, so we have to use it on +;;; the upperhalf and lowerhalf of number separately and do a little addition +;;; (actually, subtraction from the right values) to get the length. +;;; +(define-vop (signed-byte-32-len) + (:translate integer-length) + (:note "inline (signed-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (signed-reg))) + (:arg-types signed-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) number) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 16 + (let ((upper-not-zero (gen-label)) + (count (gen-label))) + ;; Move arg and tell us if number is positive. + (inst oil number arg 0) + (inst bnc :lt count) + ;; Number is negative, so logically negate it to compute length. + (inst not number) + (emit-label count) + ;; Shift the upperhalf down and see if there are any 1's in it. + (move temp number) + (inst sr temp 16) + (inst bncx :eq upper-not-zero) + (inst li res 32) + ;; Upper half is all 0's, so get ready to subtract leading 0's in + ;; the lowerhalf from 16 to determine integer length. + (inst li res 16) + (move temp number) + (emit-label upper-not-zero) + ;; Here temp contains the upperhalf if not all 0's or the lowerhalf. + ;; Res contains the appropriate value (32 or 16) from which to subtract + ;; the number of leading 0's in temp to determine integer length. + (inst clz temp) + (inst s res temp)))) + +;;; UNSIGNED-BYTE-32-COUNT -- VOP. +;;; +;;; To count the 1's in number, count how many times you can do the following: +;;; AND number and the result of subtracting 1 from number. +;;; Set number to the result of the AND operation. +;;; This subtract and AND clears the lowest 1 in number, so when number becomes +;;; zero, you're done. +;;; +(define-vop (unsigned-byte-32-count) + (:translate logcount) + (:note "inline (unsigned-byte 32) logcount") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) number temp) + (:generator 14 + (let ((loop (gen-label)) + (done (gen-label))) + ;; Move arg and tell us if number is zero, in which case res is 0. + (inst oil number arg 0) + (inst bcx :eq done) + (inst li res 0) + ;; Count 1's in number. + (emit-label loop) + (move temp number) + (inst s temp 1) + (inst n number temp) + (inst bncx :eq loop) + (inst a res 1) + ;; We're done and res already has result. + (emit-label done)))) + + + +;;;; Binary conditional VOPs: + +(define-vop (fast-conditional) + (:conditional) + (:info target not-p) + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-conditional/fixnum fast-conditional) + (:args (x :scs (any-reg)) + (y :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison")) + +(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg))) + ;; Leave room in the signed field for + (:arg-types tagged-num (:constant (signed-byte 14))) + (:info target not-p y)) + +(define-vop (fast-conditional/signed fast-conditional) + (:args (x :scs (signed-reg)) + (y :scs (signed-reg))) + (:arg-types signed-num signed-num) + (:note "inline (signed-byte 32) comparison")) + +(define-vop (fast-conditional-c/signed fast-conditional/signed) + (:args (x :scs (signed-reg))) + (:arg-types signed-num (:constant (signed-byte 16))) + (:info target not-p y)) + +(define-vop (fast-conditional/unsigned fast-conditional) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) comparison")) + +(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num (:constant (unsigned-byte 15))) + (:info target not-p y)) + + +(defmacro define-conditional-vop (translate &rest generator) + `(progn + ,@(mapcar #'(lambda (suffix cost signed) + (unless (and (member suffix '(/fixnum -c/fixnum)) + (eq translate 'eql)) + `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" + translate suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,translate) + (:generator ,cost + (let* ((signed ,signed) + (-c/fixnum ,(eq suffix '-c/fixnum)) + (y (if -c/fixnum (fixnum y) y))) + ,@generator))))) + '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) + ;; All these really take six cycles, but we decrease the -c/... + ;; cost to prefer these VOPs since we avoid doing + ;; load-immediates. Then the first two are decreased by by one + ;; more to prefer comparing the fixnum representation directly. + '(5 4 6 5 6 5) + '(t t t t nil nil)))) + +(define-conditional-vop < + (if signed + (inst c x y) + (inst cl x y)) + (if not-p + (inst bnc :lt target) + (inst bc :lt target))) + +(define-conditional-vop > + (if signed + (inst c x y) + (inst cl x y)) + (if not-p + (inst bnc :gt target) + (inst bc :gt target))) + +;;; This only handles EQL of restricted integers, so it's simple. +;;; +(define-conditional-vop eql + (declare (ignore signed)) + (inst c x y) + (if not-p + (inst bnc :eq target) + (inst bc :eq target))) + + +;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a +;;; known fixnum. +;;; + +(define-vop (fast-eql/fixnum fast-conditional) + (:args (x :scs (any-reg descriptor-reg)) + (y :scs (any-reg))) + (:arg-types * tagged-num) + (:note "inline fixnum comparison") + (:translate eql) + (:ignore temp) + (:generator 4 + (inst c x y) + (if not-p + (inst bnc :eq target) + (inst bc :eq target)))) + +(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg descriptor-reg))) + (:arg-types * (:constant (signed-byte 14))) + (:info target not-p y) + (:translate eql) + (:generator 3 + (inst c x y) + (if not-p + (inst bnc :eq target) + (inst bc :eq target)))) + + + +;;;; 32-bit logical operations + +(define-vop (32bit-logical) + (:args (x :scs (unsigned-reg) :target r) + (y :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num) + (:policy :fast-safe)) + +(define-vop (32bit-logical-not 32bit-logical) + (:translate 32bit-logical-not) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:generator 1 + (inst not r x))) + +(define-vop (32bit-logical-nor 32bit-logical) + (:translate 32bit-logical-nor) + (:generator 2 + (move r x) + (inst o r y) + (inst not r))) + +(define-vop (32bit-logical-and 32bit-logical) + (:translate 32bit-logical-and) + (:generator 1 + (move r x) + (inst n r y))) + +(define-vop (32bit-logical-or 32bit-logical) + (:translate 32bit-logical-or) + (:generator 1 + (move r x) + (inst o r y))) + +(define-vop (32bit-logical-xor 32bit-logical) + (:translate 32bit-logical-xor) + (:generator 1 + (move r x) + (inst x r y))) + + + +;;;; Bignum stuff. + +(define-vop (bignum-length get-header-data) + (:translate bignum::%bignum-length) + (:policy :fast-safe)) + +(define-vop (bignum-set-length set-header-data) + (: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-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)) + (value :scs (unsigned-reg))) + (:arg-types t positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(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 7 + (let ((done (gen-label))) + (inst c digit 0) + (inst bcx :lt done) + (move result null-tn) + (load-symbol result 't) + (emit-label done)))) + +(define-vop (add-w/carry) + (:translate bignum::%add-with-carry) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg) :target result) + (b :scs (unsigned-reg)) + (carry-in :scs (any-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg)) + (carry :scs (unsigned-reg) :from :eval)) + (:result-types unsigned-num positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 5 + (move result a) + ;; Set the carry condition bit. + (inst a temp carry-in -1) + (inst ae result b) + ;; Set carry to the condition bit. + ;; Add zero to zero and see if we get a one. + (inst li carry 0) + (inst ae carry carry))) + +(define-vop (sub-w/borrow) + (:translate bignum::%subtract-with-borrow) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg) :target result) + (b :scs (unsigned-reg)) + (borrow-in :scs (any-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg)) + (borrow :scs (unsigned-reg) :from :eval)) + (:result-types unsigned-num positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 5 + (move result a) + ;; Set the carry condition bit. + ;; Borrow-in is zero if there was a borrow, one if there was no borrow. + ;; The RT has the same sense with its C0 condition bit. + (inst a temp borrow-in -1) + (inst se result b) + ;; Set borrow to 0 if the carry condition bit is zero, or to 1 otherwise. + (inst li borrow 0) + (inst ae borrow borrow))) + +(define-vop (bignum-mult-and-add-3-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:vop-var vop) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg)) + (carry-in :scs (unsigned-reg) + :load-if (not (sc-is carry-in unsigned-stack)) + :to :save)) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp) + (:results (high :scs (unsigned-reg) :from :load) + (low :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 76 + ;; Do the multiply. + (unsigned-multiply x y high low) + + ;; Add the carry-in. + (sc-case carry-in + (unsigned-stack + (load-stack-tn temp carry-in vop) + (inst a low temp)) + (unsigned-reg + (inst a low carry-in))) + (inst ae high 0))) + +(define-vop (bignum-mult-and-add-4-arg) + (:translate bignum::%multiply-and-add) + (:vop-var vop) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg)) + (prev :scs (unsigned-reg) + :load-if (not (sc-is prev unsigned-stack)) + :to :save) + (carry-in :scs (unsigned-reg) + :load-if (not (sc-is carry-in unsigned-stack)) + :to :save)) + (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp) + (:results (high :scs (unsigned-reg) :from :load) + (low :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 81 + ;; Do the multiply. + (unsigned-multiply x y high low) + + ;; Add the carry-in. + (sc-case carry-in + (unsigned-stack + (load-stack-tn temp carry-in vop) + (inst a low temp)) + (unsigned-reg + (inst a low carry-in))) + (inst ae high 0) + + ;; Add in digit from accumulating result. + (sc-case carry-in + (unsigned-stack + (load-stack-tn temp prev vop) + (inst a low temp)) + (unsigned-reg + (inst a low prev))) + (inst ae high 0))) + +(define-vop (bignum-mult) + (:translate bignum::%multiply) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:results (high :scs (unsigned-reg) :from :load) + (low :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 74 + ;; Do the multiply. + (unsigned-multiply x y high low))) + +;;; UNSIGNED-MULTIPLY -- Internal. +;;; +;;; The RT has a signed multiply. To unsigned-multiply bignum digits, we use +;;; the following identity: +;;; signed-interpretation +;;; = unsigned-interpretation - (sign-bit)(2^32) +;;; ==> +;;; ui = si + (sb)(2^32) +;;; This gives us the following equation: +;;; (ui1) (ui2) = [si1 + (sb1)(2^32)] [si2 + (sb2)(2^32)] +;;; (ui1) (ui2) = (si1) (si2) +;;; + [(sb1)(si2) + (sb2)(si1)] (2^32) +;;; + (sb1)(sb2)(2^32) +;;; Inspection and the fact that the result must fit into 64 bits reveals that +;;; the third time can always be ignored. +;;; +(defun unsigned-multiply (x y high low) + ;; Setup system register for multiply. + (inst mtmqscr x) + + ;; Do the multiply. + ;; Subtract high from high to set it to zero and to set the C0 condition + ;; bit appropriately for the m instruction. + (inst s high high) + (dotimes (i 16) + (inst m high y)) + ;; Adjust high word of result for unsigned multiply. + ;; If x is negative, add in y. If y is negative, add in x. + (let ((x-pos (gen-label)) + (y-pos (gen-label))) + (inst c x 0) + (inst bnc :lt x-pos) + (inst a high y) + (emit-label x-pos) + (inst c y 0) + (inst bnc :lt y-pos) + (inst a high x) + (emit-label y-pos)) + + ;; Get the low 32 bits of the product. + (inst mfmqscr low)) + + +(define-vop (bignum-lognot) + (:translate bignum::%lognot) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst not r x))) + +(define-vop (fixnum-to-digit) + (:translate bignum::%fixnum-to-digit) + (:policy :fast-safe) + (:args (fixnum :scs (any-reg) :target digit)) + (:arg-types tagged-num) + (:results (digit :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (move digit fixnum) + (inst sar digit 2))) + +;;; BIGNUM-FLOOR -- VOP. +;;; +;;; The way the bignum code uses this allows us to ignore dividing by 0, 1, or +;;; -1. Furthermore, we always divided a positive high:low value by a positive +;;; divisor value. This means we don't have to worry about using the RT's +;;; signed divide instruction to get an unsigned division result. +;;; +(define-vop (bignum-floor) + (:translate bignum::%floor) + (:policy :fast-safe) + (:args (dividend-high :scs (unsigned-reg) :target rem) + (dividend-low :scs (unsigned-reg)) + (divisor :scs (unsigned-reg) :to (:eval 1))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg) :from (:eval 0))) + (:result-types unsigned-num unsigned-num) + (:generator 44 + (inst mtmqscr dividend-low) + (move rem dividend-high) + (dotimes (i 32) + (inst d rem divisor)) + ;; Check preliminary remainder by considering signs of rem and divisor. + ;; This is an extra step to account for the non-restoring divide-step instr. + ;; We don't actually have to check this since the d instruction set :c0 + ;; when the signs of rem and divisor are the same. + (let ((rem-okay (gen-label))) + (inst bc :c0 rem-okay) + (inst a rem divisor) + (emit-label rem-okay)) + (inst mfmqscr quo))) + +;;; SIGNIFY-DIGIT -- VOP. +;;; +;;; This is supposed to make digit into a fixnum which is signed. We just +;;; move it here, letting the compiler's operand motion stuff make this +;;; result into a fixnum. +;;; +(define-vop (signify-digit) + (:translate bignum::%fixnum-digit-with-correct-sign) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg) :target res)) + (:arg-types unsigned-num) + (:results (res :scs (signed-reg))) + (:result-types signed-num) + (:generator 1 + (move res digit))) + +(define-vop (digit-ashr) + (:translate bignum::%ashr) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg) :target result) + (count :scs (unsigned-reg))) + (:arg-types unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 2 + (move result digit) + (inst sar result count))) + +(define-vop (digit-lshr digit-ashr) + (:translate bignum::%digit-logical-shift-right) + (:generator 2 + (move result digit) + (inst sr result count))) + +(define-vop (digit-ashl digit-ashr) + (:translate bignum::%ashl) + (:generator 2 + (move result digit) + (inst sl result count))) + + + +;;;; Static functions. + +(define-static-function two-arg-gcd (x y) :translate gcd) +(define-static-function two-arg-lcm (x y) :translate lcm) + +(define-static-function two-arg-+ (x y) :translate +) +(define-static-function two-arg-- (x y) :translate -) +(define-static-function two-arg-* (x y) :translate *) +(define-static-function two-arg-/ (x y) :translate /) + +(define-static-function two-arg-< (x y) :translate <) +(define-static-function two-arg-<= (x y) :translate <=) +(define-static-function two-arg-> (x y) :translate >) +(define-static-function two-arg->= (x y) :translate >=) +(define-static-function two-arg-= (x y) :translate =) +(define-static-function two-arg-/= (x y) :translate /=) + +(define-static-function %negate (x) :translate %negate) + +(define-static-function two-arg-and (x y) :translate logand) +(define-static-function two-arg-ior (x y) :translate logior) +(define-static-function two-arg-xor (x y) :translate logxor) diff --git a/compiler/rt/array.lisp b/compiler/rt/array.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5d0616f8d5d2a03ae783216f78cac75d7c091381 --- /dev/null +++ b/compiler/rt/array.lisp @@ -0,0 +1,500 @@ +;;; -*- Package: C; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/array.lisp,v 1.1 1991/02/18 15:07:37 chiles Exp $ +;;; +;;; This file contains the IBM RT definitions for array operations. +;;; +;;; Written by William Lott and Bill Chiles. +;;; + +(in-package "RT") + + + +;;;; Allocator for the array header. + +(define-vop (make-array-header) + (:args (type :scs (any-reg descriptor-reg)) + (rank :scs (any-reg descriptor-reg))) + (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) + (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (:temporary (:sc word-pointer-reg) alloc) + (:results (result :scs (descriptor-reg))) + (:generator 0 + (pseudo-atomic (ndescr) + ;; Take free pointer and make descriptor pointer for the result. Just + ;; add in the three low-tag bits since alloc ptr is dual-word aligned, + ;; and its three low bits are zero. + (load-symbol-value alloc *allocation-pointer*) + (inst cal header alloc vm:other-pointer-type) + (inst cal alloc + (+ (* vm:array-dimensions-offset vm:word-bytes) + vm:lowtag-mask)) + ;; Rank is the dimensions as a fixnum which happens to be the number of + ;; bytes (by the machine's interpretation) we need to add to the alloc + ;; ptr. + (inst cas alloc rank alloc) + (inst nilo alloc (logand #xFFFF (lognot vm:lowtag-mask))) + (store-symbol-value alloc *allocation-pointer*) + (inst cal ndescr rank (fixnum (1- vm:array-dimensions-offset))) + ;; Shift the fixnum representation of the length, then OR in the fixnum + ;; rep of the type code, and then shift off the two extra fixnum zeros. + (inst sl ndescr vm:type-bits) + (inst oil ndescr type) + (inst sr ndescr 2) + (storew ndescr header 0 vm:other-pointer-type)) + (move result header))) + + + +;;;; Additional accessors and setters for the array header. + +(defknown lisp::%array-dimension (t fixnum) fixnum + (flushable)) +(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum + ()) + +(define-vop (%array-dimension word-index-ref) + (:translate lisp::%array-dimension) + (:policy :fast-safe) + (:variant vm:array-dimensions-offset vm:other-pointer-type)) + +(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)) + + + +(defknown lisp::%array-rank (t) fixnum (flushable)) + +;;; ARRAY-RANK-VOP -- VOP. +;;; +;;; The length of the array header manifests the rank of the array. We fetch +;;; the header word, extract the length, and subtract off the start of the +;;; dimension slots. +;;; +(define-vop (array-rank-vop) + (:translate lisp::%array-rank) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :type random :target res) temp) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 6 + (loadw temp x 0 vm:other-pointer-type) + (inst sr temp vm:type-bits) + (inst s temp (1- vm:array-dimensions-offset)) + (inst sl temp 2) + (move res temp))) + + + +;;;; Bounds checking routine. + +(define-vop (check-bound) + (:translate %check-bound) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg)) + (bound :scs (any-reg descriptor-reg)) + (index :scs (any-reg descriptor-reg) :target result)) + (:results (result :scs (any-reg descriptor-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((error (generate-error-code vop invalid-array-index-error + array bound index))) + (inst c index bound) + (inst bnc :lt error) + (move result index)))) + + + +;;;; 32-bit, 16-bit, and 8-bit vectors. + +;;; We build these variants on top of VOP's defined in memory.lisp. These +;;; vectors' elements are represented in integer registers and are built out of +;;; 8, 16, or 32 bit elements. + +(eval-when (compile eval) +(defmacro def-data-vector-frobs (type variant 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 immediate)) + (value :scs ,scs)) + (:results (result :scs ,scs)) + (:result-types ,element-type)))) +) ;EVAL-WHEN + +(def-data-vector-frobs simple-string byte-index + base-character base-character-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) + + + +;;;; Integer vectors with 1, 2, and 4 bit elements. + +(eval-when (compile eval) + +(defmacro def-small-data-vector-frobs (type bits) + (let* ((elements-per-word (floor vm:word-bits bits)) + (bit-shift (1- (integer-length elements-per-word)))) + `(progn + (define-vop (,(symbolicate 'data-vector-ref/ type)) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (value :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) + (:generator 20 + (move temp index) + (inst sr temp ,bit-shift) + (inst sl temp 2) + (move lip object) + (inst a lip temp) + (loadw result lip vm:vector-data-offset vm:other-pointer-type) + (inst nilz temp index ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst sl temp ,(1- (integer-length bits))))) + (inst sr result temp) + (inst nilz result ,(1- (ash 1 bits))) + (move value result) + (inst sl value 2))) + (define-vop (,(symbolicate 'data-vector-ref-c/ type)) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type (:constant index)) + (:temporary (:scs (interior-reg)) lip) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 15 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) + vm:other-pointer-type))) + (cond ((typep offset '(signed-byte 16)) + ;; Use the load with immediate offset if possible. + (inst l result offset)) + (t + ;; Load the upper half of the offset in one instruction + ;; and add the lower half as an immediate offset in + ;; the load. NOTE: if bit 15 is on, the load will sign- + ;; extend it, so we have to add 1 to the upper half now + ;; to counter the effect of the -1 from the sign-extension. + (inst cau lip object + (if (logbitp 15 offset) + (1+ (ash offset -16)) + (ash offset -16))) + (inst l result lip (logand #xFFFF offset))))) + (unless (zerop extra) + (inst sr result (* extra ,bits))) + (unless (= extra ,(1- elements-per-word)) + (inst n result ,(1- (ash 1 bits))))))) + (define-vop (,(symbolicate 'data-vector-set/ type)) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:vop-var vop) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + ;; Normally, we would take the next arg in an unsigned-reg too. + ;; This caused a discrimination problem in the compiler for + ;; choosing a move function. Since this VOP uses so many + ;; non-descriptor registers anyway which has been a hassle, we + ;; just removed unsigned-reg. + (index :scs (any-reg) :to (:eval 1)) + (value :scs (unsigned-reg immediate) + :load-if (not (sc-is value unsigned-stack)) + :target value-save)) + (:arg-types ,type positive-fixnum positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (unsigned-stack) :from (:argument 2)) value-save) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (non-descriptor-reg) :from (:argument 2) + :to (:result 0)) temp) + (:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:result 0)) + old) + (:temporary (:scs (non-descriptor-reg) :from (:eval 1) :to (:result 0)) + shift) + (:generator 25 + (when (sc-is value unsigned-reg) + (storew value (current-nfp-tn vop) (tn-offset value-save))) + (move temp index) + (inst sr temp + (sc-case index + ;; In addition to dividing the index to map it to + ;; a number of words to skip, shift off the fixnum tag + ;; bits too. + (any-reg ,(+ bit-shift 2)) + ;; No extraneous bits in this case. + (unsigned-reg ,bit-shift))) + (inst sl temp 2) + (move lip object) + (inst a lip temp) + (loadw old lip vm:vector-data-offset vm:other-pointer-type) + (sc-case index + (unsigned-reg + (inst nilz shift index ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst sl shift ,(1- (integer-length bits)))))) + (any-reg + (inst nilz shift index ,(ash (1- elements-per-word) 2)) + ,@(unless (= bits 4) + `((inst sr shift ,(- 3 (integer-length bits))))))) + + ;; Unless our immediate is all 1's, zero the destination bits. + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst li temp ,(1- (ash 1 bits))) + (inst sl temp shift) + (inst not temp) + (inst n old temp)) + ;; Unless the value is zero, really deposit it. + (unless (and (sc-is value immediate) + (zerop (tn-value value))) + (sc-case value + (immediate + (inst li temp (logand (tn-value value) ,(1- (ash 1 bits))))) + ((unsigned-reg unsigned-stack) + (loadw temp (current-nfp-tn vop) + (tn-offset (if (sc-is value unsigned-stack) + value + value-save))) + (inst nilz temp ,(1- (ash 1 bits))))) + (inst sl temp shift) + (inst o old temp)) + (storew old lip vm:vector-data-offset vm:other-pointer-type) + (sc-case value + (immediate + (inst li result (tn-value value))) + ((unsigned-reg unsigned-stack) + (loadw result (current-nfp-tn vop) + (tn-offset (if (sc-is value unsigned-stack) + value + value-save))))))) + (define-vop (,(symbolicate 'data-vector-set-c/ type)) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg immediate) :target result)) + (:arg-types ,type (:constant index) positive-fixnum) + (:temporary (:scs (interior-reg)) lip) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp old) + (:generator 20 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) + vm:other-pointer-type))) + (cond ((typep offset '(signed-byte 16)) + ;; Use the load with immediate offset if possible. + (inst l old offset)) + (t + ;; Load the upper half of the offset in one instruction + ;; and add the lower half as an immediate offset in + ;; the load. NOTE: if bit 15 is on, the load will sign- + ;; extend it, so we have to add 1 to the upper half now + ;; to counter the effect of the -1 from the sign-extension. + (inst cau lip object + (if (logbitp 15 offset) + (1+ (ash offset -16)) + (ash offset -16))) + (inst l old lip (logand #xFFFF offset))))) + ;; Unless our immediate is all 1's, zero the destination bits. + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst li temp + (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits)))) + (inst n old temp)) + ;; Unless the value is zero, really deposit it. + (unless (and (sc-is value immediate) + (zerop (tn-value value))) + (sc-case value + (immediate + (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits))) + (* extra ,bits)))) + ;; Isn't this test silly, or the otherwise branch doesn't + ;; work anyway???? + (cond ((< value #x10000) + (inst oil old (logand #xFF value)) + (inst oiu old (logand #xFF00 value))) + (t + (inst li temp value) + (inst o old temp))))) + (unsigned-reg + (move temp value) + ;; Shouldn't we do this to check the size of the value? + (inst nilz temp ,(1- (ash 1 bits))) + (inst sl temp (* extra ,bits)) + (inst o old temp)))) + (storew old object vm:vector-data-offset vm:other-pointer-type) + (sc-case value + (immediate + (inst li result (tn-value value))) + (unsigned-reg + (move result value))))))))) + +) ;EVAL-WHEN + +(def-small-data-vector-frobs simple-bit-vector 1) +(def-small-data-vector-frobs simple-array-unsigned-byte-2 2) +(def-small-data-vector-frobs simple-array-unsigned-byte-4 4) + + + +;;;; Float vectors. + +#| +(define-vop (data-vector-ref/simple-array-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-single-float positive-fixnum) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (inst add lip object index) + (inst lwc1 value lip + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst nop))) + +(define-vop (data-vector-set/simple-array-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types simple-array-single-float positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (inst add lip object index) + (inst swc1 value lip + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (unless (location= result value) + (inst move :single result value)))) + +(define-vop (data-vector-ref/simple-array-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-double-float positive-fixnum) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (inst add lip object index) + (inst add lip index) + (inst lwc1 value lip + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lwc1-odd value lip + (+ (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type) + vm:word-bytes)) + (inst nop))) + +(define-vop (data-vector-set/simple-array-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types simple-array-double-float positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (inst add lip object index) + (inst add lip index) + (inst swc1 value lip + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst swc1-odd value lip + (+ (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type) + vm:word-bytes)) + (unless (location= result value) + (inst move :double result value)))) +|# + + +;;;; Raw bits without regard to vector type. + +(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 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)) + + + +;;;; Vector subtype frobs. + +(define-vop (get-vector-subtype get-header-data)) +(define-vop (set-vector-subtype set-header-data)) diff --git a/compiler/rt/c-call.lisp b/compiler/rt/c-call.lisp new file mode 100644 index 0000000000000000000000000000000000000000..d6780ecf4cace98898e12a4fec58d9ea1cb957ac --- /dev/null +++ b/compiler/rt/c-call.lisp @@ -0,0 +1,174 @@ +;;; -*- Package: RT -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public +;;; domain. If you want to use this code or any part of CMU Common +;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/c-call.lisp,v 1.1 1991/02/18 15:07:39 chiles Exp $ +;;; +;;; This file contains the VOPs and other necessary machine specific support +;;; routines for call-out to C. +;;; +;;; Written by William Lott. +;;; Converted by Bill Chiles. +;;; + +(in-package "RT") + + + +(defun c-call-wired-tn (primitive-type sc-name offset) + (make-wired-tn (primitive-type-or-lose primitive-type) + (sc-number-or-lose sc-name) + offset)) + +(def-vm-support-routine make-call-out-nsp-tn () + (c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset)) + + +(def-vm-support-routine make-call-out-argument-tns (arg-types) + (let ((nargs 0)) + (collect ((tns)) + (dolist (type arg-types) + (multiple-value-bind + (ptype reg-sc stack-sc) + (ecase (if (consp type) (car type) type) + ((unsigned-byte port) + (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)) + (signed-byte + (values 'signed-byte-32 'signed-reg 'signed-stack)) + (system-area-pointer + (values 'system-area-pointer 'sap-reg 'sap-stack))) + ;; C expects 4 register args and the 5th arg at the top of the stack. + ;; We can't put args in registers, because we need those registers + ;; for something else. So we put them just beyond the end of the + ;; stack and the trampoline code will move them into place. + (tns (c-call-wired-tn ptype stack-sc nargs)) + (incf nargs))) + (values (tns) + (logandc2 (1+ nargs) 1))))) + +(def-vm-support-routine make-call-out-result-tn (type) + (let ((name (if (consp type) (car type) type))) + (ecase name + ((unsigned-byte port) + (c-call-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)) + (signed-byte + (c-call-wired-tn 'signed-byte-32 'signed-reg nl0-offset)) + (system-area-pointer + (c-call-wired-tn 'system-area-pointer 'sap-reg nl0-offset))))) + +(deftransform ext::call-foreign-function + ((name return-type arg-types &rest args) + (string * list &rest t)) + (assert (c::constant-continuation-p name)) + (assert (c::constant-continuation-p return-type)) + (assert (c::constant-continuation-p arg-types)) + (let ((name (c::continuation-value name)) + (return-type (c::continuation-value return-type)) + (arg-types (c::continuation-value arg-types))) + (assert (= (length arg-types) (length args))) + (if (member 'double-float arg-types) + (let ((new-args nil) + (lambda-vars nil) + (new-types nil)) + (dolist (type arg-types) + (let ((arg (gensym))) + (push arg lambda-vars) + (case type + (double-float + (push `(double-float-high-bits ,arg) new-args) + (push '(signed-byte 32) new-types) + (push `(double-float-low-bits ,arg) new-args) + (push '(unsigned-byte 32) new-types)) + (t + (push arg new-args) + (push type new-types))))) + `(lambda (name return-type arg-types ,@(nreverse lambda-vars)) + (declare (ignore name return-type arg-types)) + (ext::call-foreign-function ,name ',return-type + ',(nreverse new-types) + ,@(nreverse new-args)))) + (c::give-up)))) + +(deftransform ext::call-foreign-function + ((name return-type arg-types &rest args) + (string t * &rest t)) + (assert (c::constant-continuation-p name)) + (assert (c::constant-continuation-p return-type)) + (assert (c::constant-continuation-p arg-types)) + (let ((name (c::continuation-value name)) + (return-type (c::continuation-value return-type)) + (arg-types (c::continuation-value arg-types)) + (arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args))) + (case return-type + (double-float + `(lambda (name return-type arg-types ,@args) + (multiple-value-bind + (hi lo) + (ext::call-foreign-function ,name + '(values signed-byte unsigned-byte) + ',arg-types + ,@arg-names) + (make-double-float hi lo)))) + (single-float + `(lambda (name return-type arg-types ,@args) + (make-single-float + (ext::call-foreign-function ,name 'signed-byte ',arg-types + ,@arg-names)))) + (t + (c::give-up))))) + +(define-vop (foreign-symbol-address) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:generator 2 + (inst cai res (make-fixup (concatenate 'simple-string "_" foreign-symbol) + :foreign)))) + +(define-vop (call-out) + (:args (args :more t)) + (:results (results :more t)) + (:ignore args results) + (:save-p t) + (:info function) + (:temporary (:sc any-reg :offset nl0-offset :to (:result 0)) nl0) + (:temporary (:sc any-reg :offset lra-offset) lra) + (:temporary (:sc any-reg :offset code-offset) code) + (:temporary (:scs (sap-reg)) temp) + (: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))) + (when cur-nfp + (store-stack-tn cur-nfp nfp-save)) + (inst compute-lra-from-code lra code lra-label) + (inst cai nl0 + (make-fixup (concatenate 'simple-string "_" function) :foreign)) + (inst cai temp (make-fixup "call_into_c" :foreign)) + (inst b temp) + + (align vm:lowtag-bits) + (emit-label lra-label) + (inst lra-header-word) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:generator 0 + (unless (zerop amount) + (inst cal nsp-tn nsp-tn (- (logandc2 (+ amount 7) 7)))) + (move result nsp-tn))) + +(define-vop (dealloc-number-stack-space) + (:info amount) + (:policy :fast-safe) + (:generator 0 + (unless (zerop amount) + (inst cal nsp-tn nsp-tn (logandc2 (+ amount 7) 7))))) diff --git a/compiler/rt/call.lisp b/compiler/rt/call.lisp new file mode 100644 index 0000000000000000000000000000000000000000..75ccdf3571551aeac91349dbd51e47d83a43f17f --- /dev/null +++ b/compiler/rt/call.lisp @@ -0,0 +1,1146 @@ +;;; -*- Package: RT; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public +;;; domain. If you want to use this code or any part of CMU Common +;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of function call for the IBM RT. +;;; +;;; Written by Rob MacLachlan, William Lott, and Bill Chiles. +;;; + +(in-package "RT") + + + +;;;; Interfaces to IR2 conversion: + +;;; STANDARD-ARGUMENT-LOCATION -- Interface. +;;; +;;; Return a wired TN describing the N'th full call argument passing location. +;;; +(def-vm-support-routine standard-argument-location (n) + (declare (type unsigned-byte n)) + (if (< n register-arg-count) + (make-wired-tn *any-primitive-type* + register-arg-scn + (elt register-arg-offsets n)) + (make-wired-tn *any-primitive-type* + control-stack-arg-scn n))) + +;;; MAKE-RETURN-PC-PASSING-LOCATION -- Interface. +;;; +;;; Make a passing location TN for a local call return-PC. If standard is +;;; true, then use the standard (full call) location, otherwise use any legal +;;; location. Even in the non-standard case, this may be restricted by a +;;; desire to use a subroutine call instruction. +;;; +;;; These are *any-primitive-type* since LRA's are descriptor objects. +;;; +(def-vm-support-routine make-return-pc-passing-location (standard) + (if standard + (make-wired-tn *any-primitive-type* register-arg-scn lra-offset) + (make-restricted-tn *any-primitive-type* register-arg-scn))) + +;;; MAKE-OLD-FP-PASSING-LOCATION -- Interface. +;;; +;;; Similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a location to supply +;;; the old control FP. This is (obviously) wired in the standard convention, +;;; but is totally unrestricted in non-standard conventions, since we can +;;; always fetch it off of the stack using the arg pointer. +;;; +;;; These are *word-pointer-type* since FP's are word aligned pointers, +;;; so the low tow bits are zero. +;;; +(def-vm-support-routine make-old-fp-passing-location (standard) + (if standard + (make-wired-tn *word-pointer-type* immediate-arg-scn ocfp-offset) + (make-normal-tn *word-pointer-type*))) + +;;; MAKE-OLD-FP-SAVE-LOCATION, MAKE-RETURN-PC-SAVE-LOCATION -- Interface. +;;; +;;; Make the TN's used to hold the old control FP and return-PC within the +;;; current function. We treat these specially so that the debugger can find +;;; them at a known location. +;;; +;;; ### Fix to use specified save TNs... +;;; +;;; See comments for MAKE-RETURN-PC-PASSING-LOCATION and M-O-FP-P-L. +;;; +(def-vm-support-routine make-old-fp-save-location (env) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn *word-pointer-type*) env) + (make-wired-tn *word-pointer-type* + control-stack-arg-scn + ocfp-save-offset))) +;;; +(def-vm-support-routine make-return-pc-save-location (env) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env) + (make-wired-tn *any-primitive-type* + control-stack-arg-scn + lra-save-offset))) + +;;; MAKE-ARGUMENT-COUNT-LOCATION -- Interface. +;;; +;;; Make a TN for the standard argument count passing location. We only need +;;; to make the standard location, since a count is never passed when we are +;;; using non-standard conventions. +;;; +(def-vm-support-routine make-argument-count-location () + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) + + +;;; MAKE-NFP-TN -- Interface. +;;; +;;; Make a TN to hold the number-stack frame pointer. This is allocated once +;;; per component, and is component-live. +;;; +(def-vm-support-routine make-nfp-tn () + (component-live-tn + (make-wired-tn *word-pointer-type* immediate-arg-scn nfp-offset))) + +;;; MAKE-STACK-POINTER-TN -- Interface. +;;; +;;; This is of fixnum type because stack pointers are word aligned on our +;;; byte-addressable machine, so they have fixnum tag bits inherently. Also, +;;; GC doesn't need to fix these since the stack doesn't move. +;;; +(def-vm-support-routine make-stack-pointer-tn () + (make-normal-tn *word-pointer-type*)) + +;;; MAKE-NUMBER-STACK-POINTER-TN -- Interface. +;;; +(def-vm-support-routine make-number-stack-pointer-tn () + (make-normal-tn *word-pointer-type*)) + +;;; MAKE-UNKNOWN-VALUES-LOCATIONS -- Interface. +;;; +;;; Return a list of TN's that can be used to represent an unknown-values +;;; continuation within a function. The first one is a stack pointer TN, and +;;; the second is an argument count TN. +;;; +(def-vm-support-routine make-unknown-values-locations () + (list (make-stack-pointer-tn) + (make-normal-tn *fixnum-primitive-type*))) + + +;;; SELECT-COMPONENT-FORMAT -- Interface. +;;; +;;; This function is called by the Entry-Analyze phase, allowing VM-dependent +;;; initialization of the IR2-Component structure. We push placeholder entries +;;; in the Constants to leave room for additional noise in the code object +;;; header. +;;; +(def-vm-support-routine select-component-format (component) + (declare (type component component)) + (dotimes (i code-constants-offset) + (vector-push-extend nil + (ir2-component-constants (component-info component)))) + (undefined-value)) + + + +;;;; Frame hackery: + +;;; CURRENT-FP -- VOP. +;;; +;;; Used for setting up the OCFP in local call. +;;; +(define-vop (current-fp) + ;; Stack pointers look like fixnums, and GC doesn't need to fix them. + (:results (val :scs (word-pointer-reg))) + (:generator 1 + (move val cfp-tn))) + +;;; COMPUTE-OLD-NFP -- VOP. +;;; +;;; A returner uses this for computing the returnee's NFP for use in +;;; known-values return. Only works assuming there is no variable size stuff +;;; on the nstack. +;;; +(define-vop (compute-old-nfp) + (:results (val :scs (word-pointer-reg))) + (:vop-var vop) + (:generator 1 + (let ((nfp (current-nfp-tn vop))) + ;; We know nfp is in a register. + (when nfp + ;; The number stack grows down in memory, so the old-nfp is greater + ;; than the current one -- add a positive number. + (inst cal val nfp + (component-non-descriptor-stack-usage)))))) + +;;; XEP-ALLOCATE-FRAME -- VOP. +;;; +;;; This is the first VOP invoked by the compiler at every entry point for a +;;; component. It sets up to be dual-word aligned (because of our low-tag +;;; bits), emits the header-word for the function data-block, and emits any +;;; extra words for data about the function (such as debug-info, its name, +;;; etc.). Then it emits instructions to allocate whatever room the function +;;; will need on the control stack. +;;; +(define-vop (xep-allocate-frame) + (:info start-lab) + (:vop-var vop) + (:generator 1 + ;; Make sure the label is aligned. + (align vm:lowtag-bits) + (emit-label start-lab) + ;; Allocate function header. + (inst function-header-word) + (dotimes (i (1- vm:function-header-code-offset)) + (inst word 0)) + ;; The start of the actual code. A pointer to here is stored in symbols + ;; for named call. Make CODE point to the component from this pointer. + (let ((entry-point (gen-label))) + (emit-label entry-point) + (inst compute-code-from-fn code-tn lip-tn entry-point)) + ;; Caller has set FP to the beginning of the callee's frame. + (inst cal csp-tn cfp-tn + (* vm:word-bytes (sb-allocated-size 'control-stack))) + (let ((nfp-tn (current-nfp-tn vop))) + (when nfp-tn + (inst cal nsp-tn nsp-tn + (- (component-non-descriptor-stack-usage))) + (move nfp-tn nsp-tn))))) + +;;; ALLOCATE-FRAME -- VOP. +;;; +;;; The compiler invokes this in local call for the caller. +;;; +(define-vop (allocate-frame) + (:results (res :scs (word-pointer-reg)) + (nfp :scs (word-pointer-reg))) + (:info callee) + (:generator 2 + (move res csp-tn) + (inst cal csp-tn csp-tn + (* vm:word-bytes (sb-allocated-size 'control-stack))) + (when (ir2-environment-number-stack-p callee) + (inst cal nsp-tn nsp-tn + (- (component-non-descriptor-stack-usage))) + (move nfp nsp-tn)))) + +;;; ALLOCATE-FULL-CALL-FRAME -- VOP. +;;; +;;; Allocate a partial frame for passing stack arguments in a full call. Nargs +;;; is the number of arguments passed. If no stack arguments are passed, then +;;; we don't have to do anything. The compiler only invokes this for the +;;; caller. +;;; +(define-vop (allocate-full-call-frame) + (:info nargs) + (:results (res :scs (word-pointer-reg))) + (:generator 2 + (when (> nargs register-arg-count) + (move res csp-tn) + (inst cal csp-tn csp-tn (* nargs vm:word-bytes))))) + + + + +;;; DEFAULT-UNKNOWN-VALUES -- Internal. +;;; +;;; Emit code needed at the return-point from an unknown-values call to get or +;;; default a desired, fixed number of values. Values is the head of the +;;; TN-Ref list for the locations that the values are to be received into. +;;; Nvals is the number of values that are to be received (should equal the +;;; length of Values). +;;; +;;; Move-Temp is a Descriptor-Reg TNs used as a temporary. +;;; +;;; This code exploits the fact that in the unknown-values convention, a single +;;; value return returns at the return PC + 4, whereas a return of other than +;;; one value returns directly at the return PC. +;;; +;;; If 0 or 1 values are expected, then we just emit an instruction to reset +;;; the SP (which will only be executed when other than 1 value is returned.) +;;; +;;; In the general case, we have to do three things: +;;; -- Default unsupplied register values. This need only be done when a +;;; single value is returned, since register values are defaulted by the +;;; called in the non-single case. +;;; -- Default unsupplied stack values. This needs to be done whenever there +;;; are stack values. +;;; -- Reset SP. This must be done whenever other than 1 value is returned, +;;; regardless of the number of values desired. +;;; +;;; The general-case code looks like this: +#| + br regs-defaulted ; Skip if MVs + cau a1 0 nil-16 ; Default register values + ... + loadi nargs 1 ; Force defaulting of stack values + lr args sp ; Set up args for SP resetting + +regs-defaulted + cau nil-temp 0 nil-16 ; Cache nil + + cmpi nargs 3 ; If 4'th value unsupplied... + blex default-value-4 ; jump to default code + loadw move-temp ocfp-tn 3 ; Move value to correct location. + store-stack-tn val4-tn move-temp + + cmpi nargs 4 ; Check 5'th value, etc. + blex default-value-5 + loadw move-temp ocfp-tn 4 + store-stack-tn val5-tn move-temp + + ... + +defaulting-done + lr sp args ; Reset SP. +<end of code> + +<elsewhere> +default-value-4 + store-stack-tn val4-tn nil-temp ; Nil out 4'th value. + +default-value-5 + store-stack-tn val5-tn nil-temp ; Nil out 5'th value. + + ... + + br defaulting-done +|# +;;; +(defun default-unknown-values (values nvals move-temp lra-label) + (declare (type (or tn-ref null) values) + (type unsigned-byte nvals) (type tn move-temp)) + (cond + ((<= nvals 1) + ;; Don't use MOVE. Use a known 32-bit long instruction, so the returner + ;; can know how many bytes we used here in the multiple-value return case. + ;; The returner wants to add a known quantity to LRA indicating how many + ;; values it returned. + (inst cal csp-tn ocfp-tn 0) + (inst compute-code-from-lra code-tn code-tn lra-label)) + (t + (let ((regs-defaulted (gen-label)) + (defaulting-done (gen-label))) + ;; Branch off to the MV case. + ;; The returner has setup value registers and NARGS, and OCFP points to + ;; any stack values. + ;; Use a known 32-bit long instruction, so the returner can know how many + ;; bytes we used here in the multiple-value return case. The returner + ;; wants to add a known quantity to LRA indicating how many values it + ;; returned. + (inst bnb :pz regs-defaulted) + ;; + ;; Do the single value case. + ;; Fill in some n-1 registers with nil to get to a consistent state with + ;; having gotten multiple values, so the code after regs-defaulted can + ;; be the same for both cases. This includes setting up NARGS and OCFP. + ;; This says there's one value and no stack values. + (do ((i 1 (1+ i)) + (val (tn-ref-across values) (tn-ref-across val))) + ((= i (min nvals register-arg-count))) + (move (tn-ref-tn val) null-tn)) + ;; Only setup NARGS and OCFP we the returnee expected stack values. If + ;; it doesn't want them, then it won't look at NARGS or OCFP. + (when (> nvals register-arg-count) + (inst li nargs-tn (fixnum 1)) + (move ocfp-tn csp-tn)) + + (emit-label regs-defaulted) + (inst compute-code-from-lra code-tn code-tn lra-label) + + (when (> nvals register-arg-count) + (collect ((defaults)) + (do ((i register-arg-count (1+ i)) + (val (do ((i 0 (1+ i)) + (val values (tn-ref-across val))) + ((= i register-arg-count) val)) + (tn-ref-across val))) + ((null val)) + + (let ((default-lab (gen-label)) + (tn (tn-ref-tn val))) + (defaults (cons default-lab tn)) + (inst c nargs-tn (fixnum i)) + (inst bnbx :gt default-lab) + (loadw move-temp ocfp-tn i) + (store-stack-tn move-temp tn))) + + (emit-label defaulting-done) + (move csp-tn ocfp-tn) + + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (store-stack-tn null-tn (cdr def))) + (inst b defaulting-done))))))) + (undefined-value)) + + + +;;;; Unknown values receiving: + +;;; Receive-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return point for an unknown-values call for an +;;; arbitrary number of values. +;;; +;;; We do the single and non-single cases with no shared code: there doesn't +;;; seem to be any potential overlap, and receiving a single value is more +;;; important efficiency-wise. +;;; +;;; When there is a single value, we just push it on the stack, returning +;;; the old SP and 1. +;;; +;;; When there is a variable number of values, we move all of the argument +;;; registers onto the stack, and return Args and Nargs. +;;; +;;; Args and Nargs are TNs wired to the named locations. We must +;;; explicitly allocate these TNs, since their lifetimes overlap with the +;;; results Start and Count (also, it's nice to be able to target them). +;;; +(defun receive-unknown-values (args nargs start count lra-label) + (declare (type tn args nargs start count)) + (let ((variable-values (gen-label)) + (done (gen-label))) + ;; Use a known 32-bit long instruction, so the returner can know how many + ;; bytes we used here in the multiple-value return case. The returner + ;; wants to add a known quantity to LRA indicating how many values it + ;; returned. + (inst bnb :pz variable-values) + ;; Here's the return point for the single-value return. + (inst compute-code-from-lra code-tn code-tn lra-label) + (inst inc csp-tn vm:word-bytes) + (storew (first register-arg-tns) csp-tn -1) + (inst cal start csp-tn -4) + (inst li count (fixnum 1)) + + (emit-label done) + + (assemble (*elsewhere*) + (emit-label variable-values) + (inst compute-code-from-lra code-tn code-tn lra-label) + (do ((arg register-arg-tns (rest arg)) + (i 0 (1+ i))) + ((null arg)) + (storew (first arg) args i)) + (move start args) + (move count nargs) + (inst b done))) + (undefined-value)) + + +;;; UNKNOWN-VALUES-RECEIVER -- VOP. +;;; +;;; This is inherited by unknown values receivers. The main thing this handles +;;; is allocation of the result temporaries. This has to be included for in +;;; any VOP using RECEIVE-UNKNOWN-VALUES. +;;; +(define-vop (unknown-values-receiver) + (:results + (start :scs (word-pointer-reg)) + (count :scs (any-reg))) + (:temporary (:sc descriptor-reg :offset ocfp-offset + :from :eval :to (:result 0)) + values-start) + (:temporary (:sc any-reg :offset nargs-offset + :from :eval :to (:result 1)) + nvals)) + + + +;;;; Local call with unknown values convention return: + +;;; Non-TR local call for a fixed number of values passed according to the +;;; unknown values convention. +;;; +;;; Args are the argument passing locations, which are specified only to +;;; terminate their lifetimes in the caller. +;;; +;;; Values are the return value locations (wired to the standard passing +;;; locations). +;;; +;;; Save is the save info, which we can ignore since saving has been done. +;;; Return-PC is the TN that the return PC should be passed in. +;;; Target is a continuation pointing to the start of the called function. +;;; Nvals is the number of values received. +;;; +(define-vop (call-local) + (:args (fp :scs (word-pointer-reg)) + (nfp :scs (word-pointer-reg)) + (args :more t)) + (:results (values :more t)) + (:save-p t) + (:move-args :local-call) + (:info arg-locs callee target nvals) + (:ignore arg-locs args nfp) + (:vop-var vop) + (:temporary (:scs (descriptor-reg)) move-temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:generator 5 + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn cur-nfp nfp-save)) + (move cfp-tn fp) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (move callee-nfp nfp))) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label) + (inst b target) + (emit-return-pc label) + (note-this-location vop :unknown-return) + (default-unknown-values values nvals move-temp label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + + +;;; Non-TR local call for a variable number of return values passed according +;;; to the unknown values convention. The results are the start of the values +;;; glob and the number of values received. +;;; +(define-vop (multiple-call-local unknown-values-receiver) + (:args (fp :scs (word-pointer-reg)) + (nfp :scs (word-pointer-reg)) + (args :more t)) + (:save-p t) + (:move-args :local-call) + (:info save callee target) + (:ignore args save) + (:vop-var vop) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:generator 20 + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn cur-nfp nfp-save)) + (move cfp-tn fp) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (move callee-nfp nfp))) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label) + (inst b target) + (emit-return-pc label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + + + +;;;; Local call with known values return: + +;;; Non-TR local call with known return locations. Known-value return works +;;; just like argument passing in local call. +;;; +(define-vop (known-call-local) + (:args (fp :scs (word-pointer-reg)) + (nfp :scs (word-pointer-reg)) + (args :more t)) + (:results (res :more t)) + (:move-args :local-call) + (:save-p t) + (:info save callee target) + (:ignore args res save) + (:vop-var vop) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:generator 5 + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn cur-nfp nfp-save)) + (move cfp-tn fp) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (move callee-nfp nfp))) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label) + (inst b target) + (emit-return-pc label) + (note-this-location vop :known-return) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +(define-vop (known-return) + (:args (old-fp :scs (word-pointer-reg)) + (return-pc :scs (descriptor-reg)) + (vals :more t)) + (:temporary (:scs (interior-reg) :type interior) lip) + (:move-args :known-return) + (:info val-locs) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (move csp-tn cfp-tn) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst cal nsp-tn cur-nfp + (component-non-descriptor-stack-usage)))) + ;; Skip over a word, the LRA header, and subtract out low-tag bits. + (inst cal lip return-pc (- vm:word-bytes vm:other-pointer-type)) + (inst bx lip) + (move cfp-tn old-fp))) + + + +;;;; Full call: +;;; +;;; There is something of a cross-product effect with full calls. Different +;;; versions are used depending on whether we know the number of arguments or +;;; the name of the called function, and whether we want fixed values, unknown +;;; values, or a tail call. +;;; +;;; In full call, the arguments are passed creating a partial frame on the +;;; stack top and storing stack arguments into that frame. On entry to the +;;; callee, this partial frame is pointed to by FP. If there are no stack +;;; arguments, we don't bother allocating a partial frame, and instead set FP +;;; to SP just before the call. + +;;; Define-Full-Call -- Internal. +;;; +;;; This macro helps in the definition of full call VOPs by avoiding code +;;; replication in defining the cross-product VOPs. +;;; +;;; Name is the name of the VOP to define. +;;; +;;; Named is true if the first argument is a symbol whose global function +;;; definition is to be called. +;;; +;;; Return is either :Fixed, :Unknown or :Tail: +;;; -- If :Fixed, then the call is for a fixed number of values, returned in +;;; the standard passing locations (passed as result operands). +;;; -- If :Unknown, then the result values are pushed on the stack, and the +;;; 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. +;;; +;;; 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 +;;; passed as a more arg. Variable is true if there are a variable number of +;;; arguments passed on the stack. Variable cannot be specified with :Tail +;;; return. TR variable argument call is implemented separately. +;;; +;;; When variable is false, the compiler actually has already invoked VOP's to +;;; explicitly move arguments into their passing locations. Hence the VOP +;;; argument args (which is :more t) is actually ignored. We pass it into the +;;; call VOP's for lifetime analysis, and the TN references it represents stand +;;; in at the call site for the references to those TN's where the callee +;;; actually reads them. +;;; +;;; In tail call with fixed arguments, the passing locations are passed as a +;;; more arg, but there is no new-FP, since the arguments have been set up in +;;; the current frame. +;;; +(eval-when (compile eval) +(defmacro define-full-call (name named return variable) + (assert (not (and variable (eq return :tail)))) + `(define-vop (,name + ,@(when (eq return :unknown) + '(unknown-values-receiver))) + (:args + ,@(unless (eq return :tail) + '((new-fp :scs (word-pointer-reg) :to :eval))) + + ,(if named + '(name :scs (descriptor-reg) :target name-pass) + '(arg-fun :scs (descriptor-reg) :target lexenv)) + + ,@(when (eq return :tail) + '((old-fp :scs (word-pointer-reg) :target old-fp-pass) + (return-pc :scs (descriptor-reg) :target return-pc-pass))) + + ,@(unless variable '((args :more t)))) + + ,@(when (eq return :fixed) + '((:results (values :more t)))) + + ,@(unless (eq return :tail) + `((:save-p t) + ,@(unless variable + '((:move-args :full-call))))) + + (:vop-var vop) + (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(nargs)) + ,@(when (eq return :fixed) '(nvals))) + + (:ignore + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(args))) + + (:temporary (:sc descriptor-reg + :offset ocfp-offset + :from (:argument 1) + :to :eval) + old-fp-pass) + + (:temporary (:sc descriptor-reg + :offset lra-offset + :from (:argument ,(if (eq return :tail) 2 1)) + :to :eval) + return-pc-pass) + + ,@(if named + `((:temporary (:sc descriptor-reg :offset cname-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + name-pass)) + + `((:temporary (:sc descriptor-reg :offset lexenv-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + lexenv) + (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) + function))) + + + (:temporary (:sc descriptor-reg :offset nargs-offset :to :eval) + nargs-pass) + + ,@(when variable + (mapcar #'(lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :to :eval) + ,name)) + register-arg-names register-arg-offsets)) + ,@(when (eq return :fixed) + '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) + + ,@(unless (eq return :tail) + '((:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) + + (:temporary (:scs (interior-reg) :type interior) lip) + + (:generator ,(+ (if named 5 0) + (if variable 19 1) + (if (eq return :tail) 0 10) + 15 + (if (eq return :unknown) 25 0)) + + (let ((cur-nfp (current-nfp-tn vop)) + ,@(unless (eq return :tail) + '((lra-label (gen-label))))) + + ,@(if variable + ;; Compute the number of arguments and move some of the arguments + ;; from the stack to the argument registers. + `((move nargs-pass csp-tn) + ;; This computes a byte difference, but due to the number of + ;; bytes per word and out fixnum tags, this leaves a fixnum + ;; word count for the callee. + (inst s nargs-pass new-fp) + ,@(let ((index -1)) + (mapcar #'(lambda (name) + `(loadw ,name new-fp ,(incf index))) + register-arg-names))) + `((inst li nargs-pass (fixnum nargs)))) + + + ,@(unless (eq return :tail) + `((inst compute-lra-from-code + return-pc-pass code-tn lra-label))) + + ,@(if named + `((move name-pass name) + (loadw lip name-pass vm:symbol-raw-function-addr-slot + vm:other-pointer-type)) + `((move lexenv arg-fun) + (loadw function lexenv vm:closure-function-slot + vm:function-pointer-type) + (inst cal lip function (- (ash vm:function-header-code-offset + vm:word-shift) + vm:function-pointer-type)))) + + ,@(if (eq return :tail) + '((move old-fp-pass old-fp) + (move return-pc-pass return-pc) + (when cur-nfp + (inst cal nsp-tn cur-nfp + (component-non-descriptor-stack-usage))) + (inst b lip)) + `((move old-fp-pass cfp-tn) + (when cur-nfp + (store-stack-tn cur-nfp nfp-save)) + ,(if variable + '(move cfp-tn new-fp) + '(if (> nargs register-arg-count) + (move cfp-tn new-fp) + (move cfp-tn csp-tn))) + (inst b lip) + (emit-return-pc lra-label))) + + ,@(ecase return + (:fixed + '((note-this-location vop :unknown-return) + (default-unknown-values values nvals move-temp lra-label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:unknown + '((note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count + lra-label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:tail)))))) +) ;EVAL-WHEN + +(define-full-call call nil :fixed nil) +(define-full-call call-named t :fixed nil) +(define-full-call multiple-call nil :unknown nil) +(define-full-call multiple-call-named t :unknown nil) +(define-full-call tail-call nil :tail nil) +(define-full-call tail-call-named t :tail nil) + +(define-full-call call-variable nil :fixed t) +(define-full-call multiple-call-variable nil :unknown t) + + +;;; Defined separately, since needs special code that BLT's the arguments +;;; down. +;;; +(define-vop (tail-call-variable) + (:args (args-arg :scs (word-pointer-reg) :target args) + (function-arg :scs (descriptor-reg) :target lexenv) + (old-fp-arg :scs (word-pointer-reg) :target old-fp) + (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 ocfp-offset :from (:argument 2)) old-fp) + (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) + (:temporary (:scs (any-reg) :from :eval) temp) + (:vop-var vop) + (:generator 75 + ;; 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 lra lra-arg) + + ;; Clear the number stack if anything is there. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst cal nsp-tn cur-nfp + (component-non-descriptor-stack-usage)))) + + ;; And jump to the assembly-routine that moves the arguments for us. + (inst bala (make-fixup 'really-tail-call-variable :assembly-routine)))) + + + +;;;; Unknown values return: + + +;;; Do unknown-values return of a fixed number of values. The Values are +;;; required to be set up in the standard passing locations. Nvals is the +;;; number of values returned. +;;; +;;; If returning a single value, then deallocate the current frame, restore +;;; FP and jump to the single-value entry at Return-PC + 4. +;;; +;;; If returning other than one value, then load the number of values returned, +;;; NIL out unsupplied values registers, restore FP and return at Return-PC. +;;; When there are stack values, we must initialize the argument pointer to +;;; point to the beginning of the values block (which is the beginning of the +;;; current frame.) +;;; +(define-vop (return) + (:args + (old-fp :scs (word-pointer-reg)) + (return-pc :scs (descriptor-reg) :to (:eval 1)) + (values :more t)) + (:ignore values) + (:info nvals) + (:temporary (:sc any-reg :offset a0-offset :from (:eval 0) :to (:eval 1)) + a0) + (:temporary (:sc any-reg :offset a1-offset :from (:eval 0) :to (:eval 1)) + a1) + (:temporary (:sc any-reg :offset a2-offset :from (:eval 0) :to (:eval 1)) + a2) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) + (:temporary (:scs (interior-reg) :type interior) lip) + (:vop-var vop) + (:generator 6 + (cond ((= nvals 1) + ;; Clear the stacks. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst cal nsp-tn cur-nfp + (component-non-descriptor-stack-usage)))) + (move csp-tn cfp-tn) + ;; Reset the frame pointer. + (move cfp-tn old-fp) + ;; Out of here. + ;; The return-pc (LRA) has other-pointer lowtag bits. Also, in the + ;; instruction sequence in which the LRA points, there is a header + ;; word with immediate data indicating the offset back to the + ;; beginning of the component. The calling convention says to + ;; return one word past the return point when the returner knows + ;; it has only one value, so we skip that word here and the header + ;; for the LRA. + (inst cal lip return-pc (- (* 2 word-bytes) other-pointer-type)) + (inst bx lip) + (move code-tn return-pc)) + (t + (inst li nargs (fixnum nvals)) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst cal nsp-tn cur-nfp + (component-non-descriptor-stack-usage)))) + (move val-ptr cfp-tn) + ;; Reset the frame pointer. + (move cfp-tn old-fp) + + (let ((immediate (* nvals word-bytes))) + (assert (typep immediate '(signed-byte 16))) + (inst cal csp-tn val-ptr immediate)) + + (when (< nvals 1) (move a0 null-tn)) + (when (< nvals 2) (move a1 null-tn)) + (when (< nvals 3) (move a2 null-tn)) + + (lisp-return return-pc lip))))) + +;;; RETURN-MULTIPLE -- VOP. +;;; +;;; Do unknown-values return of an arbitrary number of values (passed on the +;;; stack.) We check for the common case of a single return value, and do that +;;; inline using the normal single value return convention. Otherwise, we +;;; branch off to an assembler routine. +;;; +;;; The Return-Multiple miscop uses a non-standard calling convention. For one +;;; thing, it doesn't return. We only use BALA because there isn't a BA +;;; instruction. Also, we don't use A0..A2 for argument passing, since the +;;; miscop will want to load these with values off of the stack. Instead, we +;;; pass Old-Fp, Start and Count in the normal locations for these values. +;;; Return-PC is passed in A3 since PC is trashed by the BALA. +;;; +(define-vop (return-multiple) + (:args + (ocfp-arg :scs (word-pointer-reg) :target ocfp) + (lra-arg :scs (descriptor-reg) :target lra) + (vals-arg :scs (word-pointer-reg) :target vals) + (nvals-arg :scs (any-reg) :target nvals)) + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) ocfp) + (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) + (:temporary (:sc any-reg :offset cname-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) + (:vop-var vop) + (:generator 13 + (let ((not-single (gen-label))) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst cal nsp-tn cur-nfp + (component-non-descriptor-stack-usage)))) + + ;; Single case? + (inst c nvals-arg (fixnum 1)) + (inst bnc :eq not-single) + + ;; Return with one value. + (loadw a0 vals-arg) + (move csp-tn cfp-tn) + (move cfp-tn ocfp-arg) + (lisp-return lra-arg lip :offset 1) + + ;; Nope, not the single case. + (emit-label not-single) + + ;; Load the register args, bailing out when we are done. + (move ocfp ocfp-arg) + (move lra lra-arg) + (move vals vals-arg) + (move nvals nvals-arg) + (inst bala (make-fixup 'really-return-multiple :assembly-routine))))) + +;;; COMPONENT-NON-DESCRIPTOR-STACK-USAGE -- Internal. +;;; +;;; This returns the non-descriptor stack usage in bytes for the component on +;;; which the compiler is currently working. +;;; +;;; On the MIPS, the stack must be dual-word aligned since it is also the C +;;; call stack. +;;; +;;; We're going to make the same assumption on the RT, but we don't even know +;;; why this is true on the MIPS. +;;; +(defun component-non-descriptor-stack-usage () + (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1) + vm:word-bytes)) + + + +;;;; XEP hackery: + + +;;; We don't need to do any special setup for regular functions. +;;; +(define-vop (setup-environment) + (:info label) + (:generator 5)) + +;;; Extract the closure from the passing location (LEXENV). +;;; +(define-vop (setup-closure-environment) + (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure + :to (:result 0)) + lexenv) + (:results (closure :scs (descriptor-reg))) + (:info label) + (:generator 6 + ;; Get result. + (move closure lexenv))) + +;;; Copy a more arg from the argument area to the end of the current frame. +;;; Fixed is the number of non-more arguments. +;;; +;;; We wire the temporaries to make sure they do not interfere with any of +;;; special registers used during full-call, because we do not have acurate +;;; lifetime info about them at the time this vop is used. +;;; +(define-vop (copy-more-arg) + (:temporary (:sc descriptor-reg :offset cname-offset) temp) + (:info fixed) + (:generator 20 + (let ((do-more-args (gen-label)) + (done-more-args (gen-label))) + (inst c nargs-tn (fixnum fixed)) + (inst bc :gt do-more-args) + (assemble (*elsewhere*) + (emit-label do-more-args) + ;; Jump to assembler routine passing fixed at cname-offset. + (inst li temp (fixnum fixed)) + (inst bala (make-fixup 'really-copy-more-args :assembly-routine)) + (inst b done-more-args)) + (emit-label done-more-args)))) + + +;;; 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)) + + +;;; Turn more arg (context, count) into a list. +;;; +(define-vop (listify-rest-args) + (:args (context-arg :target context :scs (descriptor-reg)) + (count-arg :target count :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:scs (word-pointer-reg) :from (:argument 0)) context) + (:temporary (:scs (non-descriptor-reg) :from :eval) ndescr dst) + (:temporary (:scs (any-reg) :from (:argument 1)) count) + (:temporary (:scs (word-pointer-reg) :from :eval) alloc) + (:temporary (:scs (descriptor-reg) :from :eval) temp) + (:results (result :scs (descriptor-reg))) + (:translate %listify-rest-args) + (:policy :safe) + (:generator 20 + (let ((enter (gen-label)) + (loop (gen-label)) + (done (gen-label))) + (move context context-arg) + (move count count-arg) + ;; Check to see if there are any arguments. + (inst c count 0) + (inst bcx :eq done) + (move result null-tn) + + ;; We need to do this atomically. + (pseudo-atomic (ndescr) + (load-symbol-value alloc *allocation-pointer*) + ;; Allocate a cons (2 words) for each item. + (inst cal result alloc vm:list-pointer-type) + (move dst result) + (inst cas alloc count alloc) + (inst cas alloc count alloc) + (inst bx enter) + (store-symbol-value alloc *allocation-pointer*) + + ;; Store the current cons in the cdr of the previous cons. + (emit-label loop) + (storew dst dst -1 vm:list-pointer-type) + + ;; Grab one value and stash it in the car of this cons. + (emit-label enter) + (loadw temp context) + (inst inc context vm:word-bytes) + (storew temp dst 0 vm:list-pointer-type) + + ;; Dec count, and if != zero, go back for more. + (inst s count (fixnum 1)) + (inst bncx :eq loop) + (inst inc dst (* 2 vm:word-bytes)) + + ;; NIL out the last cons. + (storew null-tn dst -1 vm:list-pointer-type)) + (emit-label done)))) + + + +;;; Return the location and size of the more arg glob created by Copy-More-Arg. +;;; Supplied is the total number of arguments supplied (originally passed in +;;; NARGS.) Fixed is the number of non-rest arguments. +;;; +;;; We must duplicate some of the work done by Copy-More-Arg, since at that +;;; time the environment is in a pretty brain-damaged state, preventing this +;;; info from being returned as values. What we do is compute +;;; supplied - fixed, and return a pointer that many words below the current +;;; stack top. +;;; +(define-vop (more-arg-context) + (:args (supplied :scs (any-reg))) + (:arg-types positive-fixnum) + (:info fixed) + (:results + (context :scs (descriptor-reg)) + (count :scs (any-reg))) + (:generator 5 + (inst s count supplied (fixnum fixed)) + (move context csp-tn) + (inst s context count))) + + +;;; Signal wrong argument count error if Nargs isn't = to Count. +;;; +(define-vop (verify-argument-count) + (:args (nargs :scs (any-reg))) + (:arg-types positive-fixnum) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (let ((err-lab + (generate-error-code vop invalid-argument-count-error nargs))) + (inst c nargs (fixnum count)) + (inst bnc :eq err-lab)))) + +;;; Signal an argument count error. +;;; +(macrolet ((frob (name error &rest args) + `(define-vop (,name) + (:args ,@(mapcar #'(lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) + args)) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1000 + (error-call vop ,error ,@args))))) + (frob argument-count-error invalid-argument-count-error nargs) + (frob type-check-error object-not-type-error object type) + (frob odd-keyword-arguments-error odd-keyword-arguments-error) + (frob unknown-keyword-argument-error unknown-keyword-argument-error key)) diff --git a/compiler/rt/cell.lisp b/compiler/rt/cell.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e617d9e8609392c5f3120014ddcd55270011fa9d --- /dev/null +++ b/compiler/rt/cell.lisp @@ -0,0 +1,337 @@ +;;; -*- Package: RT; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public +;;; domain. If you want to use this code or any part of CMU Common +;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/cell.lisp,v 1.1 1991/02/18 15:07:46 chiles Exp $ +;;; +;;; This file contains the VM definition of various primitive memory access +;;; VOPs for the IBM RT. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by Bill Chiles. +;;; + +(in-package "RT") + + + +;;;; Data object definition macros. + +(vm:define-for-each-primitive-object (obj) + (collect ((forms)) + (let ((lowtag (vm:primitive-object-lowtag obj))) + (dolist (slot (vm:primitive-object-slots obj)) + (let* ((name (vm:slot-name slot)) + (offset (vm:slot-offset slot)) + (rest-p (vm:slot-rest-p slot)) + (slot-opts (vm:slot-options slot)) + (ref-trans (getf slot-opts :ref-trans)) + (ref-vop (getf slot-opts :ref-vop ref-trans)) + (set-trans (getf slot-opts :set-trans)) + (setf-function-p (and (listp set-trans) + (= (length set-trans) 2) + (eq (car set-trans) 'setf))) + (setf-vop (getf slot-opts :setf-vop + (when setf-function-p + (intern (concatenate + 'simple-string + "SET-" + (string (cadr set-trans))))))) + (set-vop (getf slot-opts :set-vop + (if setf-vop nil set-trans)))) + (when ref-vop + (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref)) + (:variant ,offset ,lowtag) + ,@(when ref-trans + `((:translate ,ref-trans)))))) + (when (or set-vop setf-vop) + (forms `(define-vop ,(cond ((and rest-p setf-vop) + (error "Can't automatically generate ~ + a setf VOP for :rest-p ~ + slots: ~S in ~S" + name + (vm:primitive-object-name obj))) + (rest-p `(,set-vop slot-set)) + ((and set-vop setf-function-p) + (error "Setf functions (list ~S) must ~ + use :setf-vops." + set-trans)) + (set-vop `(,set-vop cell-set)) + (setf-function-p + `(,setf-vop cell-setf-function)) + (t + `(,setf-vop cell-setf))) + (:variant ,offset ,lowtag) + ,@(when set-trans + `((:translate ,set-trans))))))))) + (when (forms) + `(progn + ,@(forms))))) + + + +;;;; Symbol hacking VOPs: + +;;; CHECKED-CELL-REF -- VOP. +;;; +;;; Do a cell ref with an error check for being unbound. +;;; +(define-vop (checked-cell-ref) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (word-pointer-reg descriptor-reg any-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) + +;;; SYMBOL-VALUE -- VOP. +;;; +;;; Check that the value isn't the trap object. +;;; +(define-vop (symbol-value checked-cell-ref) + (:translate symbol-value) + (:generator 9 + (move obj-temp object) + (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type) + (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) + (inst c value vm:unbound-marker-type) + (inst bc :eq err-lab)))) + +;;; SYMBOL-FUNCTION -- VOP. +;;; +;;; Check that the result is a function, so NIL is always un-fbound. +;;; +(define-vop (symbol-function checked-cell-ref) + (:translate symbol-function) + (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:generator 10 + (move obj-temp object) + (loadw value obj-temp vm:symbol-function-slot vm:other-pointer-type) + (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) + (test-type value temp err-lab t vm:function-pointer-type)))) + + +;;; BOUNDP-FROB -- VOP. +;;; +;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. +;;; +(define-vop (boundp-frob) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:scs (descriptor-reg)) value) + (:temporary (:type random :scs (non-descriptor-reg)) temp)) + +(define-vop (boundp boundp-frob) + (:translate boundp) + (:generator 9 + (loadw value object vm:symbol-value-slot vm:other-pointer-type) + (inst c value vm:unbound-marker-type) + (if not-p + ;; If they're the same, symbol is unbound, so if not-p (the symbol is + ;; bound), then go to target. + (inst bc :eq target) + (inst bnc :eq target)))) + + +;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction +;;; on the symbol case of fboundp. Instead, we transform to a funny function. + +(defknown fboundp/symbol (t) boolean (flushable)) +;;; +(deftransform fboundp ((x) (symbol)) + '(fboundp/symbol x)) +;;; +(define-vop (fboundp/symbol boundp-frob) + (:translate fboundp/symbol) + (:generator 10 + (loadw value object vm:symbol-function-slot vm:other-pointer-type) + (test-type value temp target not-p vm:function-pointer-type))) + +(define-vop (fast-symbol-value cell-ref) + (:variant vm:symbol-value-slot vm:other-pointer-type) + (:policy :fast) + (:translate symbol-value)) + +(define-vop (fast-symbol-function cell-ref) + (:variant vm:symbol-function-slot vm:other-pointer-type) + (:policy :fast) + (:translate symbol-function)) + +(define-vop (set-symbol-function) + (:translate %sp-set-definition) + (:policy :fast-safe) + (:args (symbol :scs (descriptor-reg)) + (function :scs (descriptor-reg) :target result)) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) type) + (:temporary (:scs (any-reg)) temp) + (:save-p :compute-only) + (:vop-var vop) + (:generator 30 + (let ((closure (gen-label)) + (normal-fn (gen-label))) + (load-type type function (- vm:function-pointer-type)) + (inst c type vm:closure-header-type) + (inst bc :eq closure) + (inst c type vm:function-header-type) + (inst bcx :eq normal-fn) + (inst a temp function + (- (ash vm:function-header-code-offset vm:word-shift) + vm:function-pointer-type)) + (error-call vop kernel:object-not-function-error function) + (emit-label closure) + (inst cai temp (make-fixup "closure_tramp" :foreign)) + (emit-label normal-fn) + (storew function symbol vm:symbol-function-slot vm:other-pointer-type) + (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type) + (move result function)))) + + +(defknown fmakunbound/symbol (symbol) symbol (unsafe)) +;;; +(deftransform fmakunbound ((symbol) (symbol)) + '(progn + (fmakunbound/symbol symbol) + t)) +;;; +(define-vop (fmakunbound/symbol) + (:translate fmakunbound/symbol) + (:policy :fast-safe) + (:args (symbol :scs (descriptor-reg) :target result)) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (sap-reg)) temp) + (:generator 5 + (inst li temp vm:unbound-marker-type) + (storew temp symbol vm:symbol-function-slot vm:other-pointer-type) + (inst cai temp (make-fixup "undefined_tramp" :foreign)) + (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type) + (move result symbol))) + + +;;; Binding and Unbinding. + +;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and +;;; the symbol on the binding stack and stuff the new value into the +;;; symbol. + +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (word-pointer-reg)) bsp) + (:generator 7 + (loadw temp symbol vm:symbol-value-slot vm:other-pointer-type) + (load-symbol-value bsp *binding-stack-pointer*) + (inst inc bsp (* vm:binding-size vm:word-bytes)) + (store-symbol-value bsp *binding-stack-pointer*) + (storew temp bsp (- vm:binding-value-slot vm:binding-size)) + (storew symbol bsp (- vm:binding-symbol-slot vm:binding-size)) + (storew val symbol vm:symbol-value-slot vm:other-pointer-type))) + +(define-vop (unbind) + (:temporary (:scs (descriptor-reg)) symbol value) + (:temporary (:scs (word-pointer-reg)) bsp) + (:generator 7 + (load-symbol-value bsp *binding-stack-pointer*) + (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size)) + (loadw value bsp (- vm:binding-value-slot vm:binding-size)) + (storew value symbol vm:symbol-value-slot vm:other-pointer-type) + (inst li value 0) + (storew value bsp (- vm:binding-symbol-slot vm:binding-size)) + (inst dec bsp (* vm:binding-size vm:word-bytes)) + (store-symbol-value bsp *binding-stack-pointer*))) + +(define-vop (unbind-to-here) + (:args (arg :scs (descriptor-reg any-reg) :target where)) + (:temporary (:scs (any-reg) :from (:argument 0)) where) + (:temporary (:scs (descriptor-reg)) symbol value) + (:temporary (:scs (word-pointer-reg)) bsp) + (:generator 0 + (let ((loop (gen-label)) + (skip (gen-label)) + (done (gen-label))) + (move where arg) + (load-symbol-value bsp *binding-stack-pointer*) + (inst c where bsp) + (inst bc :eq done) + (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size)) + + (emit-label loop) + (inst c symbol 0) + (inst bc :eq skip) + (loadw value bsp (- vm:binding-value-slot vm:binding-size)) + (storew value symbol vm:symbol-value-slot vm:other-pointer-type) + (inst li value 0) + (storew value bsp (- vm:binding-symbol-slot vm:binding-size)) + + (emit-label skip) + (inst dec bsp (* vm:binding-size vm:word-bytes)) + (store-symbol-value bsp *binding-stack-pointer*) + (inst c where bsp) + (inst bnc :eq loop) + (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size)) + + (emit-label done)))) + + + +;;;; Closure indexing. + +(define-vop (closure-index-ref word-index-ref) + (:variant vm:closure-info-offset vm:function-pointer-type) + (:translate %closure-index-ref)) + + + +;;;; Structure hackery: + +(define-vop (structure-length) + (: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 res struct 0 structure-pointer-type) + (inst sr res vm:type-bits))) + +(define-vop (structure-ref slot-ref) + (:variant structure-slots-offset structure-pointer-type) + (:policy :fast-safe) + (:translate structure-ref) + (:arg-types structure (:constant index))) + +(define-vop (structure-set slot-set) + (:policy :fast-safe) + (:translate structure-set) + (: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-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 *)) + + + +;;;; Extra random indexers. + +(define-vop (code-constant-set word-index-set) + (:variant vm:code-constants-offset vm:other-pointer-type)) + diff --git a/compiler/rt/char.lisp b/compiler/rt/char.lisp new file mode 100644 index 0000000000000000000000000000000000000000..0193fb267acc6d94f536d69c55459bd868b4c23b --- /dev/null +++ b/compiler/rt/char.lisp @@ -0,0 +1,157 @@ +;;; -*- Package: RT; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/char.lisp,v 1.1 1991/02/18 15:07:48 chiles Exp $ +;;; +;;; This file contains the RT VM definition of character operations. +;;; +;;; Written by Rob MacLachlan and Bill Chiles. +;;; + +(in-package "RT") + + + +;;;; Moves and coercions: + +;;; MOVE-TO-BASE-CHARACTER -- VOP. +;;; +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-character) + (:args (x :scs (any-reg descriptor-reg) :target y)) + (:arg-types base-character) + (:results (y :scs (base-character-reg))) + (:generator 1 + (move y x) + (inst sr y vm:type-bits))) +;;; +(define-move-vop move-to-base-character :move + (any-reg descriptor-reg) (base-character-reg)) + + +;;; MOVE-FROM-BASE-CHARACTER -- VOP. +;;; +;;; Move an untagged char to a tagged representation. +;;; +(define-vop (move-from-base-character) + (:args (x :scs (base-character-reg) :target temp)) + (:temporary (:scs (base-character-reg) :from (:argument 0)) temp) + (:results (y :scs (any-reg descriptor-reg))) + (:result-types base-character) + (:generator 1 + (move temp x) + (inst sl temp vm:type-bits) + (inst oil y temp vm:base-character-type))) +;;; +(define-move-vop move-from-base-character :move + (base-character-reg) (any-reg descriptor-reg)) + +;;; BASE-CHARACTER-MOVE -- VOP. +;;; +;;; Move untagged base-character values. +;;; +(define-vop (base-character-move) + (:args (x :target y + :scs (base-character-reg) + :load-if (not (location= x y)))) + (:results (y :scs (base-character-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move y x))) +;;; +(define-move-vop base-character-move :move + (base-character-reg) (base-character-reg)) + + +;;; MOVE-BASE-CHARACTER-ARGUMENT -- VOP. +;;; +;;; Move untagged base-character arguments/return-values. +;;; +(define-vop (move-base-character-argument) + (:args (x :target y + :scs (base-character-reg)) + (fp :scs (word-pointer-reg) + :load-if (not (sc-is y base-character-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + (base-character-reg + (move y x)) + (base-character-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-base-character-argument :move-argument + (any-reg base-character-reg) (base-character-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-character +;;; to a descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (base-character-reg) (any-reg descriptor-reg)) + + + +;;;; Other operations: + +;;; CHAR-CODE -- VOP. +;;; +;;; This assumes it is best to keep characters in their raw representation. +;;; +(define-vop (char-code) + (:translate char-code) + (:policy :fast-safe) + (:args (ch :scs (base-character-reg) :target temp)) + (:arg-types base-character) + (:temporary (:scs (base-character-reg) + :from (:argument 0) :to (:result 0) + :target res) temp) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 1 + (move temp ch) + (inst sl temp 2) + (move res temp))) + +;;; CODE-CHAR -- VOP. +;;; +(define-vop (code-char) + (:translate code-char) + (:policy :fast-safe) + (:args (code :scs (any-reg) :target res)) + (:arg-types positive-fixnum) + (:results (res :scs (base-character-reg))) + (:result-types base-character) + (:generator 1 + (move res code) + (inst sr res 2))) + + + +;;; Comparison of base-characters. +;;; +(define-vop (base-character-compare pointer-compare) + (:args (x :scs (base-character-reg)) + (y :scs (base-character-reg))) + (:arg-types base-character base-character)) + +(define-vop (fast-char=/base-character base-character-compare) + (:translate char=) + (:variant :eq)) + +(define-vop (fast-char</base-character base-character-compare) + (:translate char<) + (:variant :lt)) + +(define-vop (fast-char>/base-character base-character-compare) + (:translate char>) + (:variant :gt)) diff --git a/compiler/rt/debug.lisp b/compiler/rt/debug.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b300603df4d26e534d7ef325a4ce390258ba5d09 --- /dev/null +++ b/compiler/rt/debug.lisp @@ -0,0 +1,99 @@ +;;; -*- Package: RT; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/debug.lisp,v 1.1 1991/02/18 15:07:50 chiles Exp $ +;;; +;;; Compiler support for the new whizzy debugger. +;;; +;;; Written by William Lott. +;;; Converted to RT by Bill Chiles. +;;; + +(in-package "RT") + + +(defknown di::current-sp () system-area-pointer (movable flushable)) +(defknown di::current-fp () system-area-pointer (movable flushable)) +(defknown di::stack-ref (system-area-pointer index) t (flushable)) +(defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe)) +(defknown di::lra-code-header (t) t (movable flushable)) +(defknown di::function-code-header (t) t (movable flushable)) +(defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable)) +(defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable)) + +(define-vop (debug-cur-sp) + (:translate di::current-sp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move res csp-tn))) + +(define-vop (debug-cur-fp) + (:translate di::current-fp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move res cfp-tn))) + + +(define-system-ref read-control-stack 2 di::stack-ref descriptor-reg *) + +(define-system-set write-control-stack 2 di::%set-stack-ref (descriptor-reg) *) + + +(define-vop (code-from-mumble) + (:policy :fast-safe) + (:args (thing :scs (descriptor-reg) :target code)) + (:results (code :scs (descriptor-reg))) + (:temporary (:scs (sap-reg)) temp) + (:variant-vars lowtag) + (:generator 5 + (let ((bogus (gen-label)) + (done (gen-label))) + (loadw temp thing 0 lowtag) + (inst sr temp vm:type-bits) + (inst bc :eq bogus) + (inst sl temp (1- (integer-length vm:word-bytes))) + (unless (= lowtag vm:other-pointer-type) + (inst cal temp temp (- lowtag vm:other-pointer-type))) + (move code thing) + (inst s code temp) + (emit-label done) + (assemble (*elsewhere*) + (emit-label bogus) + (inst bx done) + (move code null-tn))))) + +(define-vop (code-from-lra code-from-mumble) + (:translate di::lra-code-header) + (:variant vm:other-pointer-type)) + +(define-vop (code-from-function code-from-mumble) + (:translate di::function-code-header) + (:variant vm:function-pointer-type)) + +(define-vop (di::make-lisp-obj) + (:policy :fast-safe) + (:translate di::make-lisp-obj) + (:args (value :scs (unsigned-reg) :target result)) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:generator 1 + (move result value))) + +(define-vop (di::get-lisp-obj-address) + (:policy :fast-safe) + (:translate di::get-lisp-obj-address) + (:args (thing :scs (descriptor-reg) :target result)) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (move result thing))) diff --git a/compiler/rt/insts.lisp b/compiler/rt/insts.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b9f61b66c986d55d121c0fe2656245594b43a019 --- /dev/null +++ b/compiler/rt/insts.lisp @@ -0,0 +1,779 @@ +;;; -*- Package: RT -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public +;;; domain. If you want to use this code or any part of CMU Common +;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; Description of the IBM RT instruction set. +;;; +;;; Written by William Lott and Bill Chiles. +;;; + +(in-package "RT") + +(use-package "ASSEM") +(use-package "EXT") + + + +;;;; Formats. + +(define-format (j1 16) + (op (byte 4 12)) + (sub-op (byte 1 11)) + (n (byte 3 8)) + (j1 (byte 8 0))) + +(define-format (x 16) + (op (byte 4 12)) + (r1 (byte 4 8)) + (r2 (byte 4 4)) + (r3 (byte 4 0))) + +(define-format (d-short 16) + (op (byte 4 12)) + (i (byte 4 8)) + (r2 (byte 4 4)) + (r3 (byte 4 0))) + +(define-format (r 16) + (op (byte 8 8)) + (r2 (byte 4 4)) + (r3 (byte 4 0))) + +(define-format (bi 32) + (op (byte 8 24)) + (r2 (byte 4 20)) + (bi (byte 20 0))) + +(define-format (ba 32) + (op (byte 8 24)) + (ba (byte 24 0))) + +(define-format (d 32) + (op (byte 8 24)) + (r2 (byte 4 20)) + (r3 (byte 4 16)) + (i (byte 16 0))) + + + +;;;; Special argument types and fixups. + +(define-argument-type register + :type '(satisfies (lambda (object) + (and (tn-p object) + (or (eq (sc-name (tn-sc object)) 'null) + (eq (sb-name (sc-sb (tn-sc object))) + 'registers))))) + :function (lambda (tn) + (case (sc-name (tn-sc tn)) + (null null-offset) + (t (tn-offset tn))))) + +(defun address-register-p (object) + (and (tn-p object) + (not (zerop (tn-offset object))) + (eq (sb-name (sc-sb (tn-sc object))) 'registers))) + +(define-argument-type address-register + :type '(satisfies address-register-p) + :function tn-offset) + + +;;; LABEL-OFFSET -- Internal. +;;; +;;; This uses assem:*current-position* and the label's position to compute +;;; the bits that an instructions immediate field wants. +;;; +(defun label-offset (label) + (ash (- (label-position label) *current-position*) -1)) + +(define-argument-type relative-label + :type 'label + :function label-offset) + + +(defun jump-condition-value (cond) + (ecase cond + (:pz #b000) + (:lt #b001) + (:eq #b010) + (:gt #b011) + (:c0 #b100) + (:ov #b110) + (:tb #b111))) + +(define-argument-type jump-condition + :type '(member :pz :lt :eq :gt :c0 :ov :tb) + :function jump-condition-value) + +(defun branch-condition-value (cond) + (ecase cond + (:pz #b1000) + (:lt #b1001) + (:eq #b1010) + (:gt #b1011) + (:c0 #b1100) + (:ov #b1110) + (:tb #b1111))) + +(define-argument-type branch-condition + :type '(member :pz :lt :eq :gt :c0 :ov :tb) + :function branch-condition-value) + + +(define-fixup-type :ba) ;branch-absolute. +(define-fixup-type :cau) +(define-fixup-type :cal) + + + +;;;; Loading and storing. + +;;; load-character. +;;; +(define-instruction (lc) + (d-short (op :constant 4) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (unsigned-byte 4))) + (d-short (op :constant 4) + (r2 :argument register) + (r3 :argument address-register) + (i :constant 0)) + (d (op :constant #xCE) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (signed-byte 16)))) + +;;; store-character. +;;; +(define-instruction (stc) + (d-short (op :constant 1) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (unsigned-byte 4))) + (d-short (op :constant 1) + (r2 :argument register) + (r3 :argument address-register) + (i :constant 0)) + (d (op :constant #xDE) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (signed-byte 16)))) + +;;; load-half. +;;; +(define-instruction (lh) + (d (op :constant #xDA) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (signed-byte 16))) + (r (op :constant #xEB) + (r2 :argument register) + (r3 :argument register))) + +;;; load-half-algebraic. +;;; +(define-instruction (lha) + (d (op :constant #xCA) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (signed-byte 16))) + (d-short (op :constant 5) + (r2 :argument register) + (r3 :argument address-register) + ;; We want the instruction to take byte indexes, but we plug the + ;; index into the instruction as a half-word index. + (i :argument (member 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) + :function (lambda (x) (ash x -1))))) + +;;; store-half. +;;; +(define-instruction (sth) + (d-short (op :constant 2) + (r2 :argument register) + (r3 :argument address-register) + ;; We want the instruction to take byte indexes, but we plug the + ;; index into the instruction as a half-word index. + (i :argument (member 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) + :function (lambda (x) (ash x -1)))) + (d (op :constant #xDC) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (signed-byte 16)))) + +;;; load-word. +;;; +(define-instruction (l) + (d-short (op :constant 7) + (r2 :argument register) + (r3 :argument address-register) + ;; We want the instruction to take byte indexes, but we plug the + ;; index into the instruction as a word index. + (i :argument (member 0 4 8 12 16 20 24 28 32 36 40 44 48 52 56 60) + :function (lambda (x) (ash x -2)))) + (d-short (op :constant 7) + (r2 :argument register) + (r3 :argument address-register) + (i :constant 0)) + (d (op :constant #xCD) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (signed-byte 16)))) + +;;; store-word. +;;; +(define-instruction (st) + (d-short (op :constant 3) + (r2 :argument register) + (r3 :argument address-register) + ;; We want the instruction to take byte indexes, but we plug the + ;; index into the instruction as a word index. + (i :argument (member 0 4 8 12 16 20 24 28 32 36 40 44 48 52 56 60) + :function (lambda (x) (ash x -2)))) + (d-short (op :constant 3) + (r2 :argument register) + (r3 :argument address-register) + (i :constant 0)) + (d (op :constant #xDD) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (signed-byte 16)))) + + + +;;;; Address computation. + +;;; compute-address-lower-half. +;;; +;;; The second format can be used for load-immediate (signed-byte 16). +;;; +(define-instruction (cal) + (d (op :constant #xC8) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (signed-byte 16))) + (d (op :constant #xC8) + (r2 :argument register) + (r3 :constant 0) + (i :argument (signed-byte 16))) + (d (op :constant #xC8) + (r2 :argument register) + (r3 :argument address-register) + (i :argument cal-fixup))) + +;;; compute-address-lower-half-16bit. +;;; +;;; The second format can be used for load-immediate (unsigned-byte 16). +;;; +(define-instruction (cal16) + (d (op :constant #xC2) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (unsigned-byte 16))) + (d (op :constant #xC2) + (r2 :argument register) + (r3 :constant 0) + (i :argument (unsigned-byte 16)))) + +;;; compute-address-upper-half. +;;; +(define-instruction (cau) + (d (op :constant #xD8) + (r2 :argument register) + (r3 :argument address-register) + (i :argument (unsigned-byte 16))) + (d (op :constant #xD8) + (r2 :argument register) + (r3 :constant 0) + (i :argument (unsigned-byte 16))) + (d (op :constant #xD8) + (r2 :argument register) + (r3 :constant 0) + (i :argument cau-fixup))) + +;;; compute-address-short. +;;; +;;; Use the second flavor to copy registers. +;;; +(define-instruction (cas) + (x (op :constant 6) + (r1 :argument register) + (r2 :argument register) + (r3 :argument address-register)) + (x (op :constant 6) + (r1 :argument register) + (r2 :argument register) + (r3 :constant 0))) + +;;; increment. +;;; +(define-instruction (inc) + (r (op :constant 91) + (r2 :argument register) + (r3 :argument (unsigned-byte 4)))) + +;;; decrement +;;; +(define-instruction (dec) + (r (op :constant 93) + (r2 :argument register) + (r3 :argument (unsigned-byte 4)))) + + +;;; load-immediate-short. +;;; +(define-instruction (lis) + (r (op :constant #xA4) + (r2 :argument register) + (r3 :argument (unsigned-byte 4)))) + + + +;;;; Arithmetics. + +(macrolet ((define-math-inst (name &key two-regs short-immediate immediate + function (signed t)) + `(define-instruction (,name) + ,@(when two-regs + `((r (op :constant ,two-regs) + (r2 :argument register) + (r3 :argument register)) + (r (op :constant ,two-regs) + (r2 :argument register) + (r3 :same-as r2)))) + ,@(when short-immediate + `((r (op :constant ,short-immediate) + (r2 :argument register) + (r3 :argument (unsigned-byte 4))))) + ,@(when immediate + `((d (op :constant ,immediate) + (r2 :argument register) + (r3 :argument register) + (i :argument + (,(if signed 'signed-byte 'unsigned-byte) 16) + ,@(if function `(:function ,function)))) + (d (op :constant ,immediate) + (r2 :argument register) + (r3 :same-as r2) + (i :argument + (,(if signed 'signed-byte 'unsigned-byte) 16) + ,@(if function `(:function ,function))))))))) + + (define-math-inst a :two-regs #xE1 :short-immediate #x90 :immediate #xC1) + (define-math-inst ae :two-regs #xF1 :immediate #xD1) + (define-math-inst abs :two-regs #xE0) + (define-math-inst neg :two-regs #xE4) ;Arithmetic negation (two's complement). + (define-math-inst s :two-regs #xE2 :short-immediate #x92 + :immediate #xC1 :function -) + (define-math-inst sf :two-regs #xB2 :immediate #xD2) + (define-math-inst se :two-regs #xF2) + (define-math-inst d :two-regs #xB6) + (define-math-inst m :two-regs #xE6) + + (define-math-inst exts :two-regs #xB1) + + (define-math-inst clrbl :short-immediate #x99) + (define-math-inst clrbu :short-immediate #x98) + (define-math-inst setbl :short-immediate #x9B) + (define-math-inst setbu :short-immediate #x9A) + + (define-math-inst not :two-regs #xF4) ;Logical not. + (define-math-inst n :two-regs #xE5) + (define-math-inst nilz :immediate #xC5 :signed nil) + (define-math-inst nilo :immediate #xC6 :signed nil) + (define-math-inst niuz :immediate #xD5 :signed nil) + (define-math-inst niuo :immediate #xD6 :signed nil) + (define-math-inst o :two-regs #xE3) + (define-math-inst oil :immediate #xC4 :signed nil) + (define-math-inst oiu :immediate #xC3 :signed nil) + (define-math-inst x :two-regs #xE7) + (define-math-inst xil :immediate #xC7 :signed nil) + (define-math-inst xiu :immediate #xD7 :signed nil) + + (define-math-inst clz :two-regs #xF5) + +) ;macrolet + + +;;; compare. +;;; compare-immediate-short. +;;; compare-immediate. +;;; +(define-instruction (c) + (r (op :constant #xB4) + (r2 :argument register) + (r3 :argument register)) + (r (op :constant #x94) + (r2 :argument register) + (r3 :argument (unsigned-byte 4))) + (d (op :constant #xD4) + (r2 :constant 0) + (r3 :argument register) + (i :argument (signed-byte 16)))) + + +;;; compare-logical. +;;; compare-logical-immediate. +;;; +(define-instruction (cl) + (r (op :constant #xB3) + (r2 :argument register) + (r3 :argument register)) + (d (op :constant #xD3) + (r2 :constant 0) + (r3 :argument register) + (i :argument (signed-byte 16)))) + + + +;;;; Shifting. + +(define-instruction (sr) + (r (op :constant #xB8) + (r2 :argument register) + (r3 :argument register)) + (r (op :constant #xA8) + (r2 :argument register) + (r3 :argument (unsigned-byte 4))) + (r (op :constant #xA9) + (r2 :argument register) + (r3 :argument (integer 16 31) + :function (lambda (x) (- x 16))))) + +(define-instruction (sl) + (r (op :constant #xBA) + (r2 :argument register) + (r3 :argument register)) + (r (op :constant #xAA) + (r2 :argument register) + (r3 :argument (unsigned-byte 4))) + (r (op :constant #xAB) + (r2 :argument register) + (r3 :argument (integer 16 31) + :function (lambda (x) (- x 16))))) + +(define-instruction (sar) + (r (op :constant #xB0) + (r2 :argument register) + (r3 :argument register)) + (r (op :constant #xA0) + (r2 :argument register) + (r3 :argument (unsigned-byte 4))) + (r (op :constant #xA1) + (r2 :argument register) + (r3 :argument (integer 16 31) + :function (lambda (x) (- x 16))))) + + + +;;;; Branch instructions. + +;;; There are some pseudo-instructions defined after this page that use these +;;; definitions. +;;; + +(define-instruction (jb) + (j1 (op :constant 0) + (sub-op :constant 1) + (n :argument jump-condition) + (j1 :argument relative-label))) + +(define-instruction (jnb) + (j1 (op :constant 0) + (sub-op :constant 0) + (n :argument jump-condition) + (j1 :argument relative-label))) + +(macrolet ((define-branch-inst (name immediate-op register-op) + `(define-instruction (,name) + (bi (op :constant ,immediate-op) + (r2 :argument branch-condition) + (bi :argument relative-label)) + (r (op :constant ,register-op) + (r2 :argument branch-condition) + (r3 :argument register))))) + + ;; branch-on-condition-bit-immediate. + ;; branch-on-condition-bit-register. + ;; + (define-branch-inst bb #x8E #xEE) + + ;; branch-on-condition-bit-immediate-with-execute. + ;; branch-on-condition-bit-register-with-execute. + ;; + (define-branch-inst bbx #x8F #xEF) + + ;; branch-on-not-condition-bit-immediate. + ;; branch-on-not-condition-bit-register. + ;; + (define-branch-inst bnb #x88 #xE8) + + ;; branch-on-not-condition-bit-immediate-with-execute. + ;; branch-on-not-condition-bit-register-with-execute. + ;; + (define-branch-inst bnbx #x89 #xE9) + +) ;MACROLET + +(define-instruction (bala) + (ba (op :constant #x8A) + (ba :argument ba-fixup))) + +(define-instruction (balax) + (ba (op :constant #x8B) + (ba :argument ba-fixup))) + + + +;;;; Pseudo-instructions + +;;; move. +;;; +;;; This body is the second format of compute-address-short. +;;; +(define-instruction (move) + (x (op :constant 6) + (r1 :argument register) + (r2 :argument register) + (r3 :constant 0))) + +;;; +;;; A couple load-immediate pseudo-instructions. +;;; + +;;; load-immediate. +;;; +;;; This might affect the condition codes, but it allows for loading 32-bit +;;; quantities into R0. +;;; +(define-pseudo-instruction li 64 (reg value) + (etypecase value + ((unsigned-byte 4) + (inst lis reg value)) + ((signed-byte 16) + (inst cal reg value)) + ((unsigned-byte 16) + (inst cal16 reg value)) + ((or (signed-byte 32) (unsigned-byte 32)) + (inst cau reg (ldb (byte 16 16) value)) + (let ((low (ldb (byte 16 0) value))) + (unless (zerop low) + (inst oil reg low)))))) + +;;; compute-address-immediate. +;;; +;;; This basically exists to load 32-bit constants into address-registers, and +;;; it does not affect condition codes. Since fixups are always addresses, we +;;; have the fixup branch here instead of in load-immediate. We may use the +;;; other branches since it already exists. +;;; +(define-pseudo-instruction cai 64 (reg value) + (etypecase value + ((unsigned-byte 4) + (inst lis reg value)) + ((signed-byte 16) + (inst cal reg value)) + ((unsigned-byte 16) + (inst cal16 reg value)) + ((or (signed-byte 32) (unsigned-byte 32)) + (inst cau reg (ldb (byte 16 16) value)) + (let ((low (ldb (byte 16 0) value))) + (unless (zerop low) + (inst cal16 reg reg low)))) + (fixup + (inst cau reg value) + (inst cal reg reg value)))) + + +;;; branch-unconditional. +;;; +(define-pseudo-instruction b 32 (target) + (if (and (assem::label-p target) + (<= -128 (label-offset target) 127)) + (inst jnb :pz target) + (inst bnb :pz target))) + +;;; branch-unconditional-with-execute. +;;; +(define-pseudo-instruction bx 32 (target) + (inst bnbx :pz target)) + +;;; branch-condition. +;;; +(define-pseudo-instruction bc 32 (condition target) + (if (and (assem::label-p target) + (<= -128 (label-offset target) 127)) + (inst jb condition target) + (inst bb condition target))) + +;;; branch-not-condition. +;;; +(define-pseudo-instruction bnc 32 (condition target) + (if (and (assem::label-p target) + (<= -128 (label-offset target) 127)) + (inst jnb condition target) + (inst bnb condition target))) + +;;; branch-condition-with-execute. +;;; branch-not-condition-with-execute. +;;; +;;; We define these, so VOP readers see a consistent naming scheme in branch +;;; instructions. +;;; +(define-pseudo-instruction bcx 32 (condition target) + (inst bbx condition target)) +;;; +(define-pseudo-instruction bncx 32 (condition target) + (inst bnbx condition target)) + +;;; no-op. +;;; +;;; This is compute-address-short, adding zero to R0 putting the result in R0. +;;; +(define-instruction (no-op) + (x (op :constant 6) + (r1 :constant 0) + (r2 :constant 0) + (r3 :constant 0))) + +(define-format (word-format 32) + (data (byte 32 0))) +(define-instruction (word) + (word-format (data :argument (or (unsigned-byte 32) (signed-byte 32))))) + +(define-format (short-format 16) + (data (byte 16 0))) +(define-instruction (short) + (short-format (data :argument (or (unsigned-byte 16) (signed-byte 16))))) + +(define-format (byte-format 8) + (data (byte 8 0))) +(define-instruction (byte) + (byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8))))) + + + +;;;; Breaking. + +;;; break. +;;; +;;; This is trap-on-condition-immediate. We use the immediate field to +;;; stick in a constant value indicating why we're breaking. +;;; +(define-instruction (break) + (d (op :constant #xCC) + (r2 :constant #b0111) + (r3 :constant 0) + (i :argument (signed-byte 16)))) + + + +;;;; System control. + +;;; move-to-multiplier-quotient-system-control-register +;;; +(define-instruction (mtmqscr) + (r (op :constant #xB5) + (r2 :constant 10) + (r3 :argument register))) + +;;; move-from-multiplier-quotient-system-control-register +;;; +(define-instruction (mfmqscr) + (r (op :constant #x96) + (r2 :constant 10) + (r3 :argument register))) + + + +;;;; Function and LRA Headers emitters and calculation stuff. + +(defun header-data (ignore) + (declare (ignore ignore)) + (ash (+ *current-position* (component-header-length)) (- vm:word-shift))) + +(define-format (header-object 32) + (type (byte 8 0)) + (data (byte 24 8) :default 0 :function header-data)) + +(define-instruction (function-header-word) + (header-object (type :constant vm:function-header-type))) + +(define-instruction (lra-header-word) + (header-object (type :constant vm:return-pc-header-type))) + + +;;; DEFINE-COMPUTE-INSTRUCTION -- Internal. +;;; +;;; This defines a pseudo-instruction, name, which requires the other specific +;;; instructions. When the pseudo-instruction expands, it looks at the current +;;; value of the calculation to choose between two instruction sequences. +;;; Later, when the assembler emits the instructions, the :function's run to +;;; really compute the calculation's value. This is guaranteed to be lesser in +;;; magnitude than the original test in the pseudo-instruction since all these +;;; calculation are relative to the component start, so we can only remove +;;; instructions in that range, not add them. +;;; +(defmacro define-compute-instruction (name calculation) + (let ((cal (symbolicate name "-CAL")) + (cau (symbolicate name "-CAU"))) + `(progn + ;; This is a special compute-address-lower that takes a label and + ;; asserts the type of the immediate value. + (defun ,name (label) + (let* ((whole ,calculation) + (low (logand whole #xffff)) + (high (ash whole -16))) + (values (if (logbitp 15 low) + (1+ high) + high) + low))) + (define-instruction (,cal) + (d (op :constant #xC8) + (r2 :argument register) + (r3 :argument address-register) + (i :argument label + :function (lambda (label) + (multiple-value-bind (high low) (,name label) + (declare (ignore high)) + low))))) + (define-instruction (,cau) + (d (op :constant #xD8) + (r2 :argument register) + (r3 :argument address-register) + (i :argument label + :function (lambda (label) + (multiple-value-bind (high low) (,name label) + (declare (ignore low)) + high))))) + (define-pseudo-instruction ,name 64 (dst src label) + (multiple-value-bind (high low) (,name label) + (declare (ignore low)) + (cond ((zerop high) + (inst ,cal dst src label)) + (t + (inst ,cal dst src label) + (inst ,cau dst src label)))))))) + + +;; code = fn - header - label-offset + other-pointer-tag +(define-compute-instruction compute-code-from-fn + (- vm:other-pointer-type + (label-position label) + (component-header-length))) + +;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag +(define-compute-instruction compute-code-from-lra + (- (+ (label-position label) + (component-header-length)))) + +;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag +(define-compute-instruction compute-lra-from-code + (+ (label-position label) + (component-header-length))) diff --git a/compiler/rt/macros.lisp b/compiler/rt/macros.lisp new file mode 100644 index 0000000000000000000000000000000000000000..74d646506f1cbc5fc2d9b0367c9775a4f45c218b --- /dev/null +++ b/compiler/rt/macros.lisp @@ -0,0 +1,533 @@ +;;; -*- Package: C; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public +;;; domain. If you want to use this code or any part of CMU Common +;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; This file contains various useful macros for generating code for the IBM +;;; RT. +;;; +;;; Written by William Lott, Christopher Hoover, and Rob Maclachlin, and Bill +;;; Chiles. +;;; + +(in-package "RT") + + + +;;; Instruction-like macros. + +;;; MOVE -- Interface. +;;; +(defmacro move (dst src) + "Move src into dst unless they are LOCATION=." + (once-only ((n-dst dst) + (n-src src)) + `(unless (location= ,n-dst ,n-src) + (inst move ,n-dst ,n-src)))) + +;;; LOADW and STOREW -- Interface. +;;; +;;; Load and store words. +;;; +(macrolet ((def-mem-op (op inst) + `(defmacro ,op (object base &optional (offset 0) (lowtag 0)) + `(inst ,',inst ,object ,base + (- (ash ,offset word-shift) ,lowtag))))) + (def-mem-op loadw l) + (def-mem-op storew st)) + +;;; LOAD-SYMBOL -- Interface. +;;; +(defmacro load-symbol (reg symbol) + "Load a pointer to the static symbol into reg." + `(inst a ,reg null-tn (static-symbol-offset ,symbol))) + +;;; LOAD-SYMBOL-FUNCTION, STORE-SYMBOL-FUNCTION, +;;; LOAD-SYMBOL-VALUE, STORE-SYMBOL-VALUE -- interface. +;;; +(macrolet + ((frob (slot) + (let ((loader (intern (concatenate 'simple-string + "LOAD-SYMBOL-" + (string slot)))) + (storer (intern (concatenate 'simple-string + "STORE-SYMBOL-" + (string slot)))) + (offset (intern (concatenate 'simple-string + "SYMBOL-" + (string slot) + "-SLOT") + (find-package "VM")))) + `(progn + (defmacro ,loader (reg symbol) + `(inst l ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-type)))) + (defmacro ,storer (reg symbol) + `(inst st ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-type)))))))) + (frob value) + (frob function)) + +;;; LOAD-TYPE -- Interface. +;;; +;;; Subtract the low-tag from the pointer and add one less than the address +;;; units per word to get us to the low byte since the RT is big-endian. +;;; +(defmacro load-type (target source &optional (low-tag 0)) + "Loads the type bits from the source pointer into target, where pointer has + the specified low-tag." + `(inst lc ,target ,source (- word-bytes 1 ,low-tag))) + + + +;;;; Call and Return. + +;;; Macros to handle the fact that we cannot use the machine native call and +;;; return instructions due to low-tag bits on pointers. +;;; + +;;; LISP-JUMP -- Interface. +;;; +(defmacro lisp-jump (function lip) + "Jump to the lisp function. Lip is the lisp interior pointer register + used as a temporary." + `(progn + (inst cal ,lip ,function (- (ash function-header-code-offset + word-shift) + function-pointer-type)) + (inst bx ,lip) + (move code-tn ,function))) + +;;; LISP-RETURN -- Interface. +;;; +(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) + "Return to return-pc, an LRA. Lip is the lisp interior pointer register + used as a temporary. Offset is the number of words to skip at the target, + and it has to be small enough for whatever instruction used in here." + `(progn + (inst cal ,lip ,return-pc + (- (ash (1+ ,offset) word-shift) other-pointer-type)) + ,@(if frob-code + `((inst bx ,lip) + (move code-tn ,return-pc)) + `((inst b ,lip))))) + +;;; EMIT-RETURN-PC -- Interface. +;;; +(defmacro emit-return-pc (label) + "Emit a return-pc header word, making sure it is aligned properly for our + low-tag bits since there are other-pointers referring to the LRA's. label + is the label to use for this return-pc." + `(progn + (align lowtag-bits) + (emit-label ,label) + (inst lra-header-word))) + + +;;;; Stack TN's. + +;;; LOAD-STACK-TN, STORE-STACK-TN -- Interface. +;;; +;;; Move a stack TN to a register and vice-versa. If the VOP is supplied, +;;; we can load from (or store onto) the number stack also. +;;; +(defmacro load-stack-tn (reg stack &optional vop) + (once-only ((n-reg reg) + (n-stack stack)) + `(sc-case ,n-stack + (control-stack + (loadw ,n-reg cfp-tn (tn-offset ,n-stack))) + ,@(when vop + `(((unsigned-stack signed-stack base-character-stack sap-stack) + (loadw ,n-reg (current-nfp-tn ,vop) (tn-offset ,n-stack)))))))) +;;; +(defmacro store-stack-tn (reg stack &optional vop) + (once-only ((n-reg reg) + (n-stack stack)) + `(sc-case ,n-stack + (control-stack + (storew ,n-reg cfp-tn (tn-offset ,n-stack))) + ,@(when vop + `(((unsigned-stack signed-stack base-character-stack sap-stack) + (storew ,n-reg (current-nfp-tn ,vop) (tn-offset ,n-stack)))))))) + + +;;; MAYBE-LOAD-STACK-TN -- Interface. +;;; +(defmacro maybe-load-stack-tn (reg reg-or-stack) + "Move the TN Reg-Or-Stack into Reg if it isn't already there." + (once-only ((n-reg reg) + (n-stack reg-or-stack)) + `(sc-case ,n-reg + ((any-reg descriptor-reg) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-reg ,n-stack)) + ((control-stack) + (loadw ,n-reg fp-tn (tn-offset ,n-stack)))))))) + + + +;;;; Storage allocation: + +;;; WITH-FIXED-ALLOCATION -- Internal Interface. +;;; +(defmacro with-fixed-allocation ((result-tn header-tn alloc-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. Header-Tn is any register temp which this uses to hold the + header of the allocated object before storing it into the header slot. + Alloc-tn is a register to hold the heap pointer, and it can be any register + since raw heap pointers look like fixnums (dual-word aligned objects). The + body is placed inside PSEUDO-ATOMIC, and presumably initializes the object." + `(pseudo-atomic (,header-tn) + (load-symbol-value ,alloc-tn *allocation-pointer*) + ;; Take free pointer and make descriptor pointer. + ;; Just add in three low-tag bits since alloc ptr is dual-word aligned. + (inst cal ,result-tn ,alloc-tn other-pointer-type) + (inst cal ,alloc-tn ,alloc-tn (pad-data-block ,size)) + (store-symbol-value ,alloc-tn *allocation-pointer*) + (inst li ,header-tn (logior (ash (1- ,size) type-bits) ,type-code)) + (storew ,header-tn ,result-tn 0 other-pointer-type) + ,@body)) + + + +;;;; Type testing noise. + +;;; GEN-RANGE-TEST -- Internal. +;;; +;;; Generate code that branches to TARGET iff REG contains one of VALUES. If +;;; NOT-P is true, invert the test. Jumping to DROP-THROUGH is the same as +;;; falling out the bottom. +;;; +(defun gen-range-test (reg target drop-through not-p values + &optional (separation 1) (min 0)) + (let ((tests nil) + (start nil) + (end nil) + (insts nil)) + ;; Block off list of values into ranges, so we can test these as intervals + ;; instead of individually. + (flet ((emit-test () + (if (= start end) + (push start tests) + (push (cons start end) tests)))) + (dolist (value values) + (cond ((< value min) + (error "~S is less than the specified minimum of ~S" + value min)) + ((null start) + (setf start value)) + ((> value (+ end separation)) + (emit-test) + (setf start value))) + (setf end value)) + (emit-test)) + ;; Output tests, dealing with not-p. + (macrolet ((inst (name &rest args) + `(push (list 'inst ',name ,@args) insts))) + (do ((remaining (nreverse tests) (cdr remaining))) + ((null remaining)) + (let ((test (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom test) + (inst c reg test) + (if last + (if not-p + ;; We compared for the thing. If not-p, since it is the + ;; last thing to look for, and we don't want it, then goto + ;; target. + (inst bnc :eq target) + ;; If we do want the thing, and we got it, then goto + ;; target. + (inst bc :eq target)) + ;; If it is not the last thing, and it is not not-p, and we + ;; have it, then go to target. If not-p, and we have the thing + ;; we don't want, then drop through. + (inst bc :eq (if not-p drop-through target)))) + (t + (let ((start (car test)) + (end (cdr test))) + ;; We don't need this code if start is the smallest value we + ;; could possibly have. We know reg can't be less than start. + (unless (= start min) + (inst c reg start) + ;; If I want the range, and I'm less than the start, then + ;; drop through. If I don't want the range, goto target + ;; because I'm not in the range. + (inst bc :lt (if not-p target drop-through))) + ;; We know reg is greater than or equal to start, so see if it + ;; is less than or equal to end. + (inst c reg end) + (if last + (if not-p + ;; If this range is the last test, and I don't + ;; want it, and I'm not in it, then goto target. + (inst bc :gt target) + ;; If this range is the last test, and I want the + ;; range, and I'm in it, then goto target. + (inst bnc :gt target)) + (inst bnc :gt (if not-p drop-through target))))))))) + (nreverse insts))) + +(defconstant type-separation 4) +(defconstant min-type (+ other-immediate-0-type lowtag-limit)) + +;;; TEST-TYPE-AUX -- Internal. +;;; +(defun test-type-aux (reg temp target drop-through not-p lowtags immed hdrs) + (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql) + (member odd-fixnum-type lowtags :test #'eql))) + (lowtags (sort (if fixnump + (delete even-fixnum-type + (remove odd-fixnum-type lowtags + :test #'eql) + :test #'eql) + (copy-list lowtags)) + #'<)) + (hdrs (sort hdrs #'<)) + (immed (sort immed #'<))) + (append + (when immed + `((inst nilz ,temp ,reg type-mask) + ,@(if (or fixnump lowtags hdrs) + ;; If we're going to output any tests below, fall through to + ;; those tests from these. + (let ((fall-through (gensym))) + `((let (,fall-through (gen-label)) + ,@(gen-range-test + temp (if not-p drop-through target) + fall-through nil immed type-separation) + (emit-label ,fall-through)))) + ;; If there are no other tests, drop through to the end of all + ;; these tests. + (gen-range-test temp target drop-through not-p + immed type-separation)))) + (when fixnump + `((inst nilz ,temp ,reg 3) + ,(if (or lowtags hdrs) + ;; If more tests follow this one, fall through to them. + `(inst bc :eq ,(if not-p drop-through target)) + ;; If no more tests follow, drop totally out of here. + `(inst ,(if not-p 'bnc 'bc) :eq ,target)))) + (when (or lowtags hdrs) + `((inst nilz ,temp ,reg lowtag-mask))) + (when lowtags + (if hdrs + ;; If we're going to output any tests below, fall through to + ;; those tests from these. + (let ((fall-through (gensym))) + `((let ((,fall-through (gen-label))) + ,@(gen-range-test temp (if not-p drop-through target) + fall-through nil lowtags) + (emit-label ,fall-through)))) + (gen-range-test temp target drop-through not-p lowtags))) + (when hdrs + `((inst c ,temp other-pointer-type) + (inst bnc :eq ,(if not-p target drop-through)) + (load-type ,temp ,reg other-pointer-type) + ,@(gen-range-test temp target drop-through not-p + hdrs type-separation min-type)))))) + +(defconstant immediate-types + (list base-character-type unbound-marker-type)) + +;;; TEST-TYPE -- Interface. +;;; +;;; This is used in type-vops.lisp. +;;; +(defmacro test-type (register temp target not-p &rest type-codes) + "Register holds a descriptor object that might have one of the types in + type-codes. If it does, goto target; otherwise, fall through. If not-p is + set, goto target when register does not hold one of the types. Type-codes + must be compile-time constants that this evaluates to get numeric codes. + Temp is a non-descriptor temporary needed by the code returned by the + macro." + (let* ((type-codes (mapcar #'eval type-codes)) + (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))) + (unless type-codes + (error "Must supply at least on type for test-type.")) + (when (and headers (member other-pointer-type lowtags)) + (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers) + (setf headers nil)) + (when (and immediates + (or (member other-immediate-0-type lowtags) + (member other-immediate-1-type lowtags))) + (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates) + (setf immediates nil)) + (let ((n-reg (gensym)) + (n-temp (gensym)) + (n-target (gensym)) + (drop-through (gensym))) + `(let ((,n-reg ,register) + (,n-temp ,temp) + (,n-target ,target) + (,drop-through (gen-label))) + (declare (ignorable ,n-temp)) + ,@(if (constantp not-p) + (test-type-aux n-reg n-temp n-target drop-through + (eval not-p) lowtags immediates headers) + `((cond (,not-p + ,@(test-type-aux n-reg n-temp n-target drop-through t + lowtags immediates headers)) + (t + ,@(test-type-aux n-reg n-temp n-target drop-through nil + lowtags immediates headers))))) + (inst no-op) + (emit-label ,drop-through))))) + + + +;;;; Error Code + +(defvar *adjustable-vectors* nil) + +(defmacro with-adjustable-vector ((var) &rest body) + `(let ((,var (or (pop *adjustable-vectors*) + (make-array 16 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t)))) + (setf (fill-pointer ,var) 0) + (unwind-protect + (progn + ,@body) + (push ,var *adjustable-vectors*)))) + +(eval-when (compile load eval) + (defun emit-error-break (vop kind code values) + (let ((vector (gensym))) + `((let ((vop ,vop)) + (when vop + (note-this-location vop :internal-error))) + (inst break ,kind) + (with-adjustable-vector (,vector) + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar #'(lambda (tn) + `(let ((tn ,tn)) + (write-var-integer (make-sc-offset (sc-number + (tn-sc tn)) + (tn-offset tn)) + ,vector))) + values) + (inst byte (length ,vector)) + (dotimes (i (length ,vector)) + (inst byte (aref ,vector i)))) + (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 error-trap error-code values))) + + +;;; CERROR-CALL -- Internal Interface. +;;; +;;; Output the error break stuff followed by a branch to the continuable code. +;;; The break handler can skip the error break data, setting the pc in the +;;; signal context to our following branch, and if we continue, we're setup. +;;; +(defmacro cerror-call (vop label error-code &rest values) + "Cause a continuable error. If the error is continued, execution resumes at + LABEL." + `(progn + ,@(emit-error-break vop cerror-trap error-code values) + (inst b ,label))) + +(defmacro generate-error-code (vop error-code &rest values) + "Generate-Error-Code Error-code Value* + Emit code for an error with the specified Error-Code and context Values." + `(assemble (*elsewhere*) + (let ((start-lab (gen-label))) + (emit-label start-lab) + (error-call ,vop ,error-code ,@values) + start-lab))) + +(defmacro generate-cerror-code (vop error-code &rest values) + "Generate-CError-Code Error-code Value* + Emit code for a continuable error with the specified Error-Code and + context Values. If the error is continued, execution resumes after + the GENERATE-CERROR-CODE form." + (let ((continue (gensym "CONTINUE-LABEL-")) + (error (gensym "ERROR-LABEL-"))) + `(let ((,continue (gen-label))) + (emit-label ,continue) + (assemble (*elsewhere*) + (let ((,error (gen-label))) + (emit-label ,error) + (cerror-call ,vop ,continue ,error-code ,@values) + ,error))))) + + + +;;;; PSEUDO-ATOMIC. + +;;; PSEUDO-ATOMIC -- Internal Interface. +;;; +(defmacro pseudo-atomic ((ndescr-temp) &rest forms) + (let ((label (gensym "LABEL-"))) + `(let ((,label (gen-label))) + (inst li ,ndescr-temp 0) + (store-symbol-value ,ndescr-temp lisp::*pseudo-atomic-interrupted*) + ;; Note: we just use cfp as some not-zero value. + (store-symbol-value cfp-tn lisp::*pseudo-atomic-atomic*) + ,@forms + (inst li ,ndescr-temp 0) + (store-symbol-value ,ndescr-temp lisp::*pseudo-atomic-atomic*) + (load-symbol-value ,ndescr-temp lisp::*pseudo-atomic-interrupted*) + (inst c ,ndescr-temp 0) + (inst bc :eq ,label) + (inst break pending-interrupt-trap) + (emit-label ,label)))) + + + +;;;; Other random stuff. + +;;; PAD-DATA-BLOCK -- Internal Interface. +;;; +;;; This returns a form that returns a dual-word aligned number of bytes when +;;; given a number of words. +;;; +(defmacro pad-data-block (words) + `(logandc2 (+ (ash ,words vm:word-shift) lowtag-mask) lowtag-mask)) + + + +(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1)) + &rest identifiers) + (let ((results nil) + (index 0) + (start (eval start)) + (step (eval step))) + (dolist (id identifiers) + (when id + (multiple-value-bind + (root docs) + (if (consp id) + (values (car id) (cdr id)) + (values id nil)) + (push `(defconstant ,(intern (concatenate 'simple-string + (string prefix) + (string root) + (string suffix))) + ,(+ start (* step index)) + ,@docs) + results))) + (incf index)) + `(eval-when (compile load eval) + ,@(nreverse results)))) diff --git a/compiler/rt/memory.lisp b/compiler/rt/memory.lisp new file mode 100644 index 0000000000000000000000000000000000000000..209840624f20d73d2441661b879e41e9ad256f36 --- /dev/null +++ b/compiler/rt/memory.lisp @@ -0,0 +1,182 @@ +;;; -*- Package: RT; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/memory.lisp,v 1.1 1991/02/18 15:07:59 chiles Exp $ +;;; +;;; This file contains the IBM RT definitions of some general purpose memory +;;; reference VOPs inherited by basic memory reference operations. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by Bill Chiles. +;;; + +(in-package "RT") + + +;;; CELL-REF -- VOP. +;;; CELL-SET -- VOP. +;;; CELL-SETF -- VOP. +;;; CELL-SETF-FUNCTION -- VOP. +;;; +;;; CELL-REF and CELL-SET are used to define VOPs like CAR, where the offset to +;;; be read or written is a property of the VOP used. CELL-SETF is similar to +;;; CELL-SET, but delivers the new value as the result. CELL-SETF-FUNCTION +;;; takes its arguments as if it were a setf function (new value first, as +;;; apposed to a setf macro, which takes the new value last). +;;; +(define-vop (cell-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (word-pointer-reg descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (loadw value object offset lowtag))) +;;; +(define-vop (cell-set) + (:args (object :scs (descriptor-reg)) + (value :scs (word-pointer-reg descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag))) +;;; +(define-vop (cell-setf) + (:args (object :scs (descriptor-reg)) + (value :scs (word-pointer-reg descriptor-reg any-reg) + :target result)) + (:results (result :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag) + (move result value))) +;;; +(define-vop (cell-setf-function) + (:args (value :scs (word-pointer-reg descriptor-reg any-reg) + :target result) + (object :scs (descriptor-reg))) + (:results (result :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag) + (move result value))) + +;;; DEFINE-CELL-ACCESSORS -- Interface. +;;; +;;; Define accessor VOPs for some cells in an object. If the operation name is +;;; NIL, then that operation isn't defined. If the translate function is null, +;;; then we don't define a translation. +;;; +(defmacro define-cell-accessors (offset lowtag ref-op ref-trans set-op set-trans) + `(progn + ,@(when ref-op + `((define-vop (,ref-op cell-ref) + (:variant ,offset ,lowtag) + ,@(when ref-trans + `((:translate ,ref-trans)))))) + ,@(when set-op + `((define-vop (,set-op cell-setf) + (:variant ,offset ,lowtag) + ,@(when set-trans + `((:translate ,set-trans)))))))) + + +;;; SLOT-REF -- VOP. +;;; SLOT-SET -- VOP. +;;; +;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF, where the +;;; offset is constant at compile time, but varies for different uses. We add +;;; in the stardard g-vector overhead. +;;; +(define-vop (slot-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (loadw value object (+ base offset) lowtag))) +;;; +(define-vop (slot-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (storew value object (+ base offset) lowtag))) + + + +;;;; Indexed references: + +(eval-when (compile eval) + +;;; 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. +;;; +(defmacro define-indexer (name write-p op shift &key gross-hack) + `(define-vop (,name) + (:args (object :scs (descriptor-reg) :to :eval) + (index :scs (any-reg immediate) + ,@(unless (zerop shift) '(:target temp))) + ,@(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 :from (:argument 1)) + 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) + (inst ,op value object + (- (+ (if (and (sc-is index immediate) (zerop (tn-value index))) + 0 + (ash (tn-value index) (- word-shift ,shift))) + (ash offset word-shift)) + lowtag)) + ,@(if write-p + '((move result value)))) + (t + ,@(if (zerop shift) + ;; Object must be the last arg to CAS here since it is cannot + ;; be in R0. + `((inst cas lip index object)) + `((move temp index) + (inst sr temp ,shift) + (inst cas lip temp object))) + (inst ,op value lip (- (ash offset word-shift) lowtag)) + ,@(if write-p + '((move result value))))) + ;; The RT lacks a signed-byte load instruction, so we have to sign + ;; extend this case explicitly. This is gross but obvious and easy. + ,@(when gross-hack + '((inst sl value 24) + (inst sar value 24)))))) + +) ;EVAL-WHEN + +(define-indexer word-index-ref nil l 0) +(define-indexer word-index-set t st 0) +(define-indexer halfword-index-ref nil lh 1) +(define-indexer signed-halfword-index-ref nil lha 1) +(define-indexer halfword-index-set t sth 1) +(define-indexer byte-index-ref nil lc 2) +(define-indexer signed-byte-index-ref nil lc 2 :gross-hack t) +(define-indexer byte-index-set t stc 2) diff --git a/compiler/rt/move.lisp b/compiler/rt/move.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6dd174d883f777469c4e450513674ce587ecbd42 --- /dev/null +++ b/compiler/rt/move.lisp @@ -0,0 +1,353 @@ +;;; -*- Package: RT; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/move.lisp,v 1.1 1991/02/18 15:08:01 chiles Exp $ +;;; +;;; This file contains the IBM RT VM definition of operand loading/saving and the +;;; Move VOP. +;;; +;;; Written by Rob MacLachlan. +;;; MIPS conversion by William Lott. +;;; IBM RT conversion by William Lott and Bill Chiles. +;;; + +(in-package "RT") + + +(define-move-function (load-immediate 1) (vop x y) + ((null immediate) + (any-reg word-pointer-reg descriptor-reg)) + (let ((val (tn-value x))) + (etypecase val + (integer + (inst li y (fixnum val))) + (null + (move y null-tn)) + (symbol + (load-symbol y val)) + (character + (inst li y (logior (ash (char-code val) type-bits) + base-character-type)))))) + +(define-move-function (load-number 1) (vop x y) + ((immediate) + (signed-reg unsigned-reg)) + (inst li y (tn-value x))) + +(define-move-function (load-base-character 1) (vop x y) + ((immediate) (base-character-reg)) + (inst li y (char-code (tn-value x)))) + +(define-move-function (load-system-area-pointer 1) (vop x y) + ((immediate) (sap-reg)) + (inst li y (sap-int (tn-value x)))) + +(define-move-function (load-constant 5) (vop x y) + ((constant) (descriptor-reg)) + (loadw y code-tn (tn-offset x) other-pointer-type)) + +(define-move-function (load-stack 5) (vop x y) + ((control-stack) (any-reg word-pointer-reg descriptor-reg)) + (load-stack-tn y x)) + +(define-move-function (load-number-stack 5) (vop x y) + ((base-character-stack) (base-character-reg) + (sap-stack) (sap-reg) + (signed-stack) (signed-reg) + (unsigned-stack) (unsigned-reg)) + (load-stack-tn y x vop)) + +(define-move-function (store-stack 5) (vop x y) + ((any-reg word-pointer-reg descriptor-reg) (control-stack)) + (store-stack-tn x y)) + +(define-move-function (store-number-stack 5) (vop x y) + ((base-character-reg) (base-character-stack) + (sap-reg) (sap-stack) + (signed-reg) (signed-stack) + (unsigned-reg) (unsigned-stack)) + (store-stack-tn x y vop)) + +(define-move-function (word-pointer-copy 1) (vop x y) + ((word-pointer-reg) (any-reg) + (any-reg) (word-pointer-reg)) + (move y x)) + + + +;;;; The Move VOP: + +(define-vop (move) + (:args (x :target y + :scs (any-reg word-pointer-reg descriptor-reg) + :load-if (not (location= x y)))) + (:results (y :scs (any-reg word-pointer-reg descriptor-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move y x))) + +(define-move-vop move :move + (any-reg word-pointer-reg descriptor-reg) + (any-reg word-pointer-reg descriptor-reg)) + +;;; Make Move the check VOP for T so that type check generation doesn't think +;;; it is a hairy type. This also allows checking of a few of the values in a +;;; continuation to fall out. +;;; +(primitive-type-vop move (:check) t) + +;;; MOVE-ARGUMENT -- VOP. +;;; +;;; This is used for moving descriptor values into another frame for argument +;;; or known value passing. +;;; +(define-vop (move-argument) + (:args (x :target y + :scs (any-reg word-pointer-reg descriptor-reg)) + (fp :scs (word-pointer-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + ((any-reg word-pointer-reg descriptor-reg) + (move y x)) + (control-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-argument :move-argument + (any-reg word-pointer-reg descriptor-reg) + (any-reg word-pointer-reg descriptor-reg)) + + + +;;;; ILLEGAL-MOVE + +;;; ILLEGAL-MOVE -- VOP. +;;; +;;; This VOP exists just to begin the lifetime of a TN that couldn't be written +;;; legally due to a type error. An error is signalled before this VOP is so +;;; we don't need to do anything (not that there would be anything sensible to +;;; do anyway.) +;;; +(define-vop (illegal-move) + (:args (x) (type)) + (:results (y)) + (:ignore y) + (:vop-var vop) + (:save-p :compute-only) + (:generator 666 + (error-call vop object-not-type-error x type))) + + + +;;;; Moves and coercions: + +;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word +;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer +;;; to a tagged bignum or fixnum. + +;;; MOVE-TO-WORD/FIXNUM -- VOP. +;;; +;;; Arg is a fixnum, so just put it in a non-descriptor register and shift it. +;;; +(define-vop (move-to-word/fixnum) + (:args (x :scs (any-reg) :target y)) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "fixnum untagging") + (:generator 2 + (move y x) + (inst sar y 2))) +;;; +(define-move-vop move-to-word/fixnum :move + (any-reg) (signed-reg unsigned-reg)) + +;;; MOVE-TO-WORD-C -- VOP. +;;; +;;; Arg is a non-immediate constant, load it. +;;; +(define-vop (move-to-word-c) + (:args (x :scs (constant))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "constant load") + (:generator 1 + (inst li y (tn-value x)))) +;;; +(define-move-vop move-to-word-c :move + (constant) (signed-reg unsigned-reg)) + +;;; MOVE-TO-WORD/INTEGER -- VOP. +;;; +;;; Arg is a fixnum or bignum, figure out which and load if necessary. +;;; +(define-vop (move-to-word/integer) + (:args (x :scs (descriptor-reg) :to :save)) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "integer to untagged word coercion") + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 8 + (let ((done (gen-label))) + (inst nilz temp x 3) + (move y x) + (inst bcx :eq done) + (inst sar y 2) + ;; If it's a bignum, throw away what we computed in y. + (loadw y x bignum-digits-offset other-pointer-type) + (emit-label done)))) +;;; +(define-move-vop move-to-word/integer :move + (descriptor-reg) (signed-reg unsigned-reg)) + + +;;; MOVE-FROM-WORD/FIXNUM -- VOP. +;;; +;;; Since the result is know to be a fixnum, we can shift in the tag bits +;;; without fear of needing a bignum. +;;; +(define-vop (move-from-word/fixnum) + (:args (x :scs (signed-reg unsigned-reg) :target temp)) + (:temporary (:scs (non-descriptor-reg) + :from (:argument 0) :to (:result 0) :target y) + temp) + (:results (y :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note "fixnum tagging") + (:generator 3 + (move temp x) + (inst sl temp 2) + (move y temp))) +;;; +(define-move-vop move-from-word/fixnum :move + (signed-reg unsigned-reg) (any-reg descriptor-reg)) + +;;; MOVE-FROM-SIGNED -- VOP. +;;; +;;; Result may be a bignum, so we have to check whether shifting to make room +;;; for tag bits results in a fixnum. Use a worst-case cost to make sure +;;; people know they may be number consing. +;;; +(define-vop (move-from-signed) + (: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 (:scs (word-pointer-reg)) alloc) + (:note "signed word to integer coercion") + (:generator 25 + (move x arg) + (let ((fixnum (gen-label)) + (done (gen-label))) + (move temp x) + (inst sar temp 29) + (inst bcx :eq fixnum) + (inst not temp) + (inst bc :eq fixnum) + + (with-fixed-allocation (y temp alloc bignum-type 2) + (storew x y bignum-digits-offset other-pointer-type)) + (inst b done) + + (emit-label fixnum) + (move y x) + (inst sl y 2) + (emit-label done)))) +;;; +(define-move-vop move-from-signed :move + (signed-reg) (descriptor-reg)) + + +;;; MOVE-FROM-UNSIGNED -- VOP. +;;; +;;; Check for fixnum, and possibly allocate one or two word bignum result. Use +;;; a worst-case cost to make sure people know they may be number consing. +;;; +(define-vop (move-from-unsigned) + (: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 (:scs (word-pointer-reg)) alloc) + (:note "unsigned word to integer coercion") + (:generator 21 + (move x arg) + (let ((done (gen-label)) + (bignum (gen-label)) + (one-word (gen-label))) + (move temp x) + (inst sar temp 29) + (inst bnc :eq bignum) + (inst sl x 2) + (move y x) + (emit-label done) + + (assemble (*elsewhere*) + (emit-label bignum) + (pseudo-atomic (temp) + (load-symbol-value alloc *allocation-pointer*) + (inst cal y alloc other-pointer-type) + (inst cal alloc alloc (pad-data-block (1+ bignum-digits-offset))) + (inst c x 0) + (inst bncx :lt one-word) + (inst li temp (logior (ash 1 type-bits) bignum-type)) + (inst cal alloc alloc + (- (pad-data-block (+ 2 bignum-digits-offset)) + (pad-data-block (1+ bignum-digits-offset)))) + (inst li temp (logior (ash 2 type-bits) bignum-type)) + (emit-label one-word) + (store-symbol-value alloc *allocation-pointer*) + (storew temp y 0 other-pointer-type) + (storew x y bignum-digits-offset other-pointer-type)) + (inst b done))))) +;;; +(define-move-vop move-from-unsigned :move + (unsigned-reg) (descriptor-reg)) + + +;;; Move untagged numbers. +;;; +(define-vop (word-move) + (:args (x :target y + :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:results (y :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:note "word integer move") + (:generator 0 + (move y x))) +;;; +(define-move-vop word-move :move + (signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Move untagged number arguments/return-values. +;;; +(define-vop (move-word-argument) + (:args (x :target y + :scs (signed-reg unsigned-reg)) + (fp :scs (word-pointer-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note "word integer argument move") + (:generator 0 + (sc-case y + ((signed-reg unsigned-reg) + (move y x)) + ((signed-stack unsigned-stack) + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-word-argument :move-argument + (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff --git a/compiler/rt/nlx.lisp b/compiler/rt/nlx.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b8a71c0ad75289e850dcf1dfbfb4b2decce9b92d --- /dev/null +++ b/compiler/rt/nlx.lisp @@ -0,0 +1,330 @@ +;;; -*- Package: RT -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/nlx.lisp,v 1.1 1991/02/18 15:08:03 chiles Exp $ +;;; +;;; This file contains the definitions of VOPs used for non-local exit (throw, +;;; lexical exit, etc.) +;;; +;;; Written by Rob MacLachlan +;;; Converted to IBM RT by William Lott and Bill Chiles. +;;; + +(in-package "RT") + + +;;; MAKE-NLX-SP-TN -- Interface. +;;; +;;; Make an environment-live stack TN for saving the SP for NLX entry. +;;; +(def-vm-support-routine make-nlx-sp-tn (env) + (environment-live-tn + (make-representation-tn *word-pointer-type* + (sc-number-or-lose 'word-pointer-reg *backend*)) + env)) + + + +;;; Save and restore dynamic environment. +;;; +;;; These VOPs are used in the reentered function to restore the appropriate +;;; dynamic environment. Currently we only save the Current-Catch and binding +;;; stack pointer. We don't need to save/restore the current unwind-protect, +;;; since unwind-protects are implicitly processed during unwinding. If there +;;; were any additional stacks, then this would be the place to restore the top +;;; pointers. + + +;;; MAKE-DYNAMIC-STATE-TNS -- Interface. +;;; +;;; Return a list of TNs that can be used to snapshot the dynamic state for use +;;; with the Save/Restore-Dynamic-Environment VOPs. +;;; +(def-vm-support-routine make-dynamic-state-tns () + (make-n-tns 5 *fixnum-primitive-type*)) + +(define-vop (save-dynamic-state) + (:results (catch :scs (any-reg)) + (special :scs (any-reg)) + (nfp :scs (any-reg)) + (nsp :scs (any-reg)) + (eval :scs (any-reg))) + (:vop-var vop) + (:generator 13 + (load-symbol-value catch lisp::*current-catch-block*) + (load-symbol-value special *binding-stack-pointer*) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move nfp cur-nfp))) + (move nsp nsp-tn) + (load-symbol-value eval lisp::*eval-stack-top*))) + +(define-vop (restore-dynamic-state) + (:args (catch :scs (any-reg)) + (special :scs (any-reg) :to (:eval 1)) + (nfp :scs (any-reg)) + (nsp :scs (any-reg)) + (eval :scs (any-reg))) + (:temporary (:scs (descriptor-reg) :from (:eval 0)) symbol value) + (:temporary (:scs (word-pointer-reg) :from (:eval 0)) bsp) + (:vop-var vop) + (:generator 10 + (let ((done (gen-label)) + (skip (gen-label)) + (loop (gen-label))) + + (store-symbol-value catch lisp::*current-catch-block*) + (store-symbol-value eval lisp::*eval-stack-top*) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move cur-nfp nfp))) + (move nsp-tn nsp) + + (load-symbol-value bsp *binding-stack-pointer*) + (inst c bsp 0) + (inst bc :eq done) + + ;; Unwind shallow dynamic bindings. + (emit-label loop) + (loadw symbol bsp (- binding-symbol-slot binding-size)) + (inst c symbol 0) + (inst bc :eq skip) + (loadw value bsp (- binding-value-slot binding-size)) + (storew value symbol vm:symbol-value-slot vm:other-pointer-type) + (inst li value 0) + (storew value bsp (- binding-symbol-slot binding-size)) + (emit-label skip) + (inst dec bsp (* 2 vm:word-bytes)) + (inst c bsp special) + (inst bnc :eq loop) + + (emit-label done) + (store-symbol-value special *binding-stack-pointer*)))) + +(define-vop (current-stack-pointer) + (:results (res :scs (any-reg word-pointer-reg descriptor-reg))) + (:generator 1 + (move res csp-tn))) + +(define-vop (current-binding-pointer) + (:results (res :scs (any-reg word-pointer-reg descriptor-reg))) + (:generator 1 + (load-symbol-value res *binding-stack-pointer*))) + + + +;;;; Unwind block hackery: + +;;; MAKE-UNWIND-BLOCK -- VOP. +;;; +;;; Compute the address of the catch block from its TN, then store into the +;;; block the current Fp, Env, Unwind-Protect, and the entry PC. +;;; +(define-vop (make-unwind-block) + (:args (tn)) + (:info entry-label) + (:results (block :scs (word-pointer-reg))) + (:temporary (:scs (word-pointer-reg) :target block) block-ptr) + (:temporary (:scs (descriptor-reg)) temp) + (:generator 22 + (inst cal block-ptr cfp-tn (* (tn-offset tn) vm:word-bytes)) + (load-symbol-value temp lisp::*current-unwind-protect-block*) + (storew temp block-ptr vm:unwind-block-current-uwp-slot) + (storew cfp-tn block-ptr vm:unwind-block-current-cont-slot) + (storew code-tn block-ptr vm:unwind-block-current-code-slot) + (inst compute-lra-from-code temp code-tn entry-label) + (storew temp block-ptr vm:catch-block-entry-pc-slot) + (move block block-ptr))) + + +;;; MAKE-CATCH-BLOCK -- VOP. +;;; +;;; Like MAKE-UNWIND-BLOCK, except that we also store in the specified tag, and +;;; link the block into the Current-Catch list. +;;; +(define-vop (make-catch-block) + (:args (tn) + (tag :scs (descriptor-reg))) + (:info entry-label) + (:results (block :scs (word-pointer-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (word-pointer-reg) :target block :to (:result 0)) result) + (:generator 44 + (inst cal 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 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) + (storew temp result vm:catch-block-entry-pc-slot) + + (storew tag result vm:catch-block-tag-slot) + (load-symbol-value temp lisp::*current-catch-block*) + (storew temp result vm:catch-block-previous-catch-slot) + (store-symbol-value result lisp::*current-catch-block*) + + (move block result))) + + +;;; SET-UNWIND-PROTECT -- VOP. +;;; +;;; Just set the current unwind-protect to TN's address. This instantiates an +;;; unwind block as an unwind-protect. +;;; +(define-vop (set-unwind-protect) + (:args (tn)) + (:temporary (:scs (descriptor-reg)) new-uwp) + (:generator 7 + (inst cal new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes)) + (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) + +;;; UNLINK-CATCH-BLOCK -- VOP. +;;; +;;; Remove the catch block from the chain of catches. This happens when +;;; we drop out of a catch instead of throwing. +;;; +(define-vop (unlink-catch-block) + (:temporary (:scs (word-pointer-reg)) block) + (:policy :fast-safe) + (:translate %catch-breakup) + (:generator 17 + (load-symbol-value block lisp::*current-catch-block*) + (loadw block block vm:catch-block-previous-catch-slot) + (store-symbol-value block lisp::*current-catch-block*))) + +;;; UNLINK-UNWIND-PROTECT -- VOP. +;;; +;;; Same thing with unwind protects. +;;; +(define-vop (unlink-unwind-protect) + (:temporary (:scs (word-pointer-reg)) block) + (:policy :fast-safe) + (:translate %unwind-protect-breakup) + (:generator 17 + (load-symbol-value block lisp::*current-unwind-protect-block*) + (loadw block block vm:unwind-block-current-uwp-slot) + (store-symbol-value block lisp::*current-unwind-protect-block*))) + + +;;;; NLX entry VOPs: + + +;;; NLX-ENTRY -- VOP. +;;; +;;; We were just thrown to, so load up the results. +;;; +(define-vop (nlx-entry) + (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops + ; would be inserted before the LRA. + (start) + (count)) + (:results (values :more t)) + (:temporary (:scs (descriptor-reg)) move-temp) + (:info label nvals) + (:save-p :force-to-stack) + (:generator 30 + (emit-return-pc label) + (cond ((zerop nvals)) + ((= nvals 1) + (let ((no-values (gen-label))) + (inst c count 0) + (inst bcx :eq no-values) + (move (tn-ref-tn values) null-tn) + (loadw (tn-ref-tn values) start) + (emit-label no-values))) + (t + (collect ((defaults)) + (inst c count 0) + (do ((i 0 (1+ i)) + (tn-ref values (tn-ref-across tn-ref))) + ((null tn-ref)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn tn-ref))) + (defaults (cons default-lab tn)) + + (inst bc :eq default-lab) + (inst s count (fixnum 1)) + (sc-case tn + ((descriptor-reg any-reg) + (loadw tn start i)) + (control-stack + (loadw move-temp start i) + (store-stack-tn move-temp tn))))) + + (let ((defaulting-done (gen-label))) + (emit-label defaulting-done) + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (let ((tn (cdr def))) + (sc-case tn + ((descriptor-reg any-reg) + (move tn null-tn)) + (control-stack + (store-stack-tn null-tn tn))))) + (inst b defaulting-done)))))) + (load-stack-tn csp-tn sp))) + + +(define-vop (nlx-entry-multiple) + ;; Again, no SC restrictions for the args, 'cause the loading would + ;; happen before the entry label. But we know that start and count will + ;; be in registers due to the way this vop is used. + (:args (top :target dst) + (start :target src) + (count :target num)) + (:info label) + (:temporary (:scs (any-reg) :from (:argument 0)) dst) + (:temporary (:scs (any-reg) :from (:argument 1)) src) + (:temporary (:scs (any-reg) :from (:argument 2)) num) + (:temporary (:scs (descriptor-reg)) temp) + (:results (new-start) (new-count)) + (:save-p :force-to-stack) + (:generator 30 + (emit-return-pc label) + (let ((loop (gen-label)) + (done (gen-label))) + + ;; Copy args. + (load-stack-tn dst top) + (move src start) + (inst a num count 0) + + ;; Establish results. + (sc-case new-start + ((any-reg word-pointer-reg) (move new-start dst)) + (control-stack (store-stack-tn dst new-start))) + (inst bcx :eq done) + (sc-case new-count + (any-reg (inst move new-count num)) + (control-stack (store-stack-tn num new-count))) + + ;; Copy stuff on stack. + (emit-label loop) + (loadw temp src) + (inst inc src vm:word-bytes) + (storew temp dst) + (inst s num num (fixnum 1)) + (inst bncx :eq loop) + (inst inc dst vm:word-bytes) + + (emit-label done) + (move csp-tn dst)))) + + +;;; This VOP is just to force the TNs used in the cleanup onto the stack. +;;; +(define-vop (uwp-entry) + (:info label) + (:save-p :force-to-stack) + (:results (block) (start) (count)) + (:ignore block start count) + (:generator 0 + (emit-return-pc label))) + diff --git a/compiler/rt/params.lisp b/compiler/rt/params.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e271ccb7878aaebfa4da56df29ac79bf369acb4e --- /dev/null +++ b/compiler/rt/params.lisp @@ -0,0 +1,175 @@ +;;; -*- Package: RT; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public +;;; domain. If you want to use this code or any part of CMU Common +;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/params.lisp,v 1.1 1991/02/18 15:08:05 chiles Exp $ +;;; +;;; This file contains some parameterizations of various VM attributes for the +;;; IBM RT. This file is separate from other stuff, so we can compile and +;;; load it earlier. +;;; +;;; Written by Rob MacLachlan +;;; Converted to MIPS by William Lott. +;;; Converted to IBM RT by William Lott and Bill Chiles. +;;; + +(in-package "RT") +(use-package "C") + +(export '(word-bits byte-bits word-shift word-bytes + halt-trap pending-interrupt-trap error-trap cerror-trap)) + + + +;;;; Compiler constants. + +(eval-when (compile eval load) + +(setf (backend-name *target-backend*) "RT") +(setf (backend-version *target-backend*) "IBM RT/Mach 0.0") +(setf (backend-fasl-file-type *target-backend*) "rtf") +(setf (backend-fasl-file-implementation *target-backend*) + rt-fasl-file-implementation) +(setf (backend-fasl-file-version *target-backend*) 1) +(setf (backend-register-save-penalty *target-backend*) 3) +(setf (backend-byte-order *target-backend*) :big-endian) + +) ;eval-when + + + +;;;; Machine Architecture parameters: + +(eval-when (compile load eval) + +(defconstant word-bits 32 + "Number of bits per word where a word holds one lisp descriptor.") + +(defconstant byte-bits 8 + "Number of bits per byte where a byte is the smallest addressable object.") + +(defconstant word-shift (1- (integer-length (/ word-bits byte-bits))) + "Number of bits to shift between word addresses and byte addresses.") + +(defconstant word-bytes (/ word-bits byte-bits) + "Number of bytes in a word.") + +(defparameter target-most-positive-fixnum (1- (ash 1 29)) + "most-positive-fixnum in the target architecture.") + +(defparameter target-most-negative-fixnum (ash -1 29) + "most-negative-fixnum in the target architecture.") + +(defconstant float-sign-shift 31) + +;;; The exponent min/max values are wrong, I think. The denorm, infinity, etc. +;;; info must go in there somewhere. + +(defconstant single-float-bias 126) +(defconstant single-float-exponent-byte (byte 8 23)) +(defconstant single-float-significand-byte (byte 23 0)) +(defconstant single-float-normal-exponent-min 0) +(defconstant single-float-normal-exponent-max 255) +(defconstant single-float-hidden-bit (ash 1 23)) + +(defconstant double-float-bias 1022) +(defconstant double-float-exponent-byte (byte 11 20)) +(defconstant double-float-significand-byte (byte 20 0)) +(defconstant double-float-normal-exponent-min 0) +(defconstant double-float-normal-exponent-max #x7FF) +(defconstant double-float-hidden-bit (ash 1 20)) + +(defconstant single-float-digits + (+ (byte-size single-float-significand-byte) 1)) + +(defconstant double-float-digits + (+ (byte-size double-float-significand-byte) word-bits 1)) + +); eval-when + + + + +;;;; Description of the target address space. + +;;; Where to put the different spaces. +;;; +(defparameter target-read-only-space-start #x00100000) +(defparameter target-static-space-start #x04000000) +(defparameter target-dynamic-space-start #x06000000) + + + +;;;; Other non-type constants. + +(defenum (:suffix -trap :start 8) + halt + pending-interrupt + error + cerror) + + + +;;;; Static symbols. + +;;; These symbols are loaded into static space directly after NIL so +;;; that the system can compute their address by adding a constant +;;; amount to NIL. +;;; +;;; The exported static symbols are a subset of the static symbols that get +;;; exported to the C header file. NOTE: EXPORTED-STATIC-SYMBOLS IS DEFINED +;;; AS A FUNCTION OF THE ORDERING OF THIS LIST. +;;; +(defparameter static-symbols + '(t + + ;; Random stuff needed for initialization. + lisp::lisp-environment-list + lisp::lisp-command-line-list + + ;; Functions that C needs to call. + lisp::%initial-function + lisp::maybe-gc + kernel::internal-error + + ;; Free Pointers + lisp::*read-only-space-free-pointer* + lisp::*static-space-free-pointer* + lisp::*initial-dynamic-space-free-pointer* + rt::*allocation-pointer* + rt::*binding-stack-pointer* + + ;; Things needed for non-local-exit. + lisp::*current-catch-block* + lisp::*current-unwind-protect-block* + *eval-stack-top* + + ;; Interrupt Handling + lisp::*pseudo-atomic-atomic* + lisp::*pseudo-atomic-interrupted* + mach::*interrupts-enabled* + mach::*interrupt-pending* + lisp::*free-interrupt-context-index* + + ;; Static functions. + two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= + two-arg-<= two-arg->= two-arg-/= %negate two-arg-and two-arg-ior two-arg-xor + length two-arg-gcd two-arg-lcm + )) + +(defparameter exported-static-symbols + (subseq static-symbols 0 (1+ (position 'lisp::*free-interrupt-context-index* + static-symbols)))) + + + +;;;; Assembler parameters: + +;;; The number of bits per element in the assemblers code vector. +;;; +(defparameter *assembly-unit-length* 8) diff --git a/compiler/rt/pred.lisp b/compiler/rt/pred.lisp new file mode 100644 index 0000000000000000000000000000000000000000..9c8973595c705225f04d1c2d2b648f0c216aef1e --- /dev/null +++ b/compiler/rt/pred.lisp @@ -0,0 +1,53 @@ +;;; -*- Package: C; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/pred.lisp,v 1.1 1991/02/18 15:08:07 chiles Exp $ +;;; +;;; This file contains the VM definition of predicate VOPs for the IBM RT. +;;; +;;; Written by Rob MacLachlan +;;; Modified by William Lott and Bill Chiles for the IBM RT. +;;; + +(in-package "RT") + + + +;;;; The Branch VOP. + +;;; The unconditional branch, emitted when we can't drop through to the desired +;;; destination. Dest is the label where we want to be. +;;; +(define-vop (branch) + (:info dest) + (:generator 5 + (inst b dest))) + + + +;;;; Conditional VOPs: + +(define-vop (if-eq) + (:args (x :scs (any-reg descriptor-reg null)) + (y :scs (any-reg descriptor-reg null))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:translate eq) + (:generator 3 + (let ((x-prime (sc-case x + ((any-reg descriptor-reg) x) + (null null-tn))) + (y-prime (sc-case y + ((any-reg descriptor-reg) y) + (null null-tn)))) + (inst c x-prime y-prime) + (if not-p + (inst bnc :eq target) + (inst bc :eq target))))) diff --git a/compiler/rt/print.lisp b/compiler/rt/print.lisp new file mode 100644 index 0000000000000000000000000000000000000000..41ce17395c5e2412e6c9c5ef35b8bb66250b786e --- /dev/null +++ b/compiler/rt/print.lisp @@ -0,0 +1,48 @@ +;;; -*- Package: RT -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public +;;; domain. If you want to use this code or any part of CMU Common +;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/print.lisp,v 1.1 1991/02/18 15:08:08 chiles Exp $ +;;; +;;; This file contains temporary printing utilities and similar noise. +;;; +;;; Written by William Lott. +;;; + +(in-package "RT") + + +(define-vop (print) + (:args (object :scs (descriptor-reg))) + (:results (result :scs (descriptor-reg))) + (:save-p t) + (:temporary (:sc any-reg :offset nl0-offset) nl0) + (:temporary (:sc any-reg :offset lra-offset) lra) + (:temporary (:sc any-reg :offset code-offset) code) + (:temporary (:scs (sap-reg)) temp) + (: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))) + (when cur-nfp + (store-stack-tn cur-nfp nfp-save)) + (inst cal nsp-tn nsp-tn -16) + (storew object nsp-tn) + (inst compute-lra-from-code lra code lra-label) + (inst cai nl0 (make-fixup "_debug_print" :foreign)) + (inst cai temp (make-fixup "call_into_c" :foreign)) + (inst b temp) + + (align vm:lowtag-bits) + (emit-label lra-label) + (inst lra-header-word) + (inst cal nsp-tn nsp-tn 16) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + (move result nl0)))) diff --git a/compiler/rt/sap.lisp b/compiler/rt/sap.lisp new file mode 100644 index 0000000000000000000000000000000000000000..605e329644de47cd9c2ae9d4363ac3a568d20f55 --- /dev/null +++ b/compiler/rt/sap.lisp @@ -0,0 +1,380 @@ +;;; -*- Package: RT; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/sap.lisp,v 1.1 1991/02/18 15:08:09 chiles Exp $ +;;; +;;; This file contains the IBM RT VM definition of SAP operations. +;;; +;;; Written by William Lott. +;;; + +(in-package "RT") + + + +;;;; Moves and coercions: + +;;; MOVE-TO-SAP -- VOP. +;;; +;;; Move a tagged SAP to an untagged representation. +;;; +(define-vop (move-to-sap) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (sap-reg))) + (:generator 1 + (loadw y x vm:sap-pointer-slot vm:other-pointer-type))) +;;; +(define-move-vop move-to-sap :move + (descriptor-reg) (sap-reg)) + + +;;; MOVE-FROM-SAP -- VOP. +;;; +;;; Move an untagged SAP to a tagged representation. +;;; +(define-vop (move-from-sap) + (:args (sap :scs (sap-reg) :to :save)) + (:temporary (:sc any-reg) header) + (:temporary (:sc word-pointer-reg) alloc) + (:results (y :scs (descriptor-reg))) + (:generator 1 + (with-fixed-allocation (y header alloc vm:other-pointer-type vm:sap-size) + (storew sap y vm:sap-pointer-slot vm:other-pointer-type)))) +;;; +(define-move-vop move-from-sap :move + (sap-reg) (descriptor-reg)) + + +;;; SAP-MOVE -- VOP. +;;; +;;; Move untagged sap values. +;;; +(define-vop (sap-move) + (:args (x :target y + :scs (sap-reg) + :load-if (not (location= x y)))) + (:results (y :scs (sap-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move y x))) +;;; +(define-move-vop sap-move :move + (sap-reg) (sap-reg)) + + +;;; MOVE-SAP-ARGUMENT -- VOP. +;;; +;;; Move untagged sap arguments/return-values. +;;; +(define-vop (move-sap-argument) + (:args (x :target y + :scs (sap-reg)) + (fp :scs (word-pointer-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + (sap-reg + (move y x)) + (sap-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-sap-argument :move-argument + (descriptor-reg sap-reg) (sap-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (sap-reg) (descriptor-reg)) + + + +;;;; SAP-INT and INT-SAP + +(define-vop (sap-int) + (:args (sap :scs (sap-reg) :target int)) + (:arg-types system-area-pointer) + (:results (int :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate sap-int) + (:policy :fast-safe) + (:generator 1 + (move int sap))) + +(define-vop (int-sap) + (:args (int :scs (unsigned-reg) :target sap)) + (:arg-types unsigned-num) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate int-sap) + (:policy :fast-safe) + (:generator 1 + (move sap int))) + + + +;;;; POINTER+ and POINTER- + +(define-vop (pointer+) + (:translate sap+) + (:args (ptr :scs (sap-reg) :target res) + (offset :scs (signed-reg) :to :save)) + (:arg-types system-area-pointer signed-num) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 2 + ;; Can't use CAS since offset and ptr may be register 0, so we have to move. + (move res ptr) + (inst a res offset))) +;;; +(define-vop (pointer+-c pointer+) + (:args (ptr :scs (sap-reg))) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 16))) + (:generator 1 + (inst a res ptr offset))) + +(define-vop (pointer-) + (:translate sap-) + (:args (ptr1 :scs (sap-reg) :target res) + (ptr2 :scs (sap-reg) :to :save)) + (:arg-types system-area-pointer system-area-pointer) + (:policy :fast-safe) + (:results (res :scs (signed-reg))) + (:result-types signed-num) + (:generator 1 + (move res ptr1) + (inst s res ptr2))) + + + +;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET + +(eval-when (compile eval) + +;;; DEFINE-SYSTEM-REF -- Internal Interface. +;;; +;;; Name is the name of a computed system-ref offset, from which we generate a +;;; <name>-c VOP for immediate constant offsets. Shift is the multiples of two +;;; for which we must adjust the offset to make it an index in terms of bytes +;;; (the machines address units). Translate and signed-translate are the Lisp +;;; function calls for which these VOP's are in-line expansions. +;;; +(defmacro define-system-ref (name shift + translate result-sc result-type + &optional + signed-translate signed-result-sc + signed-result-type) + (let ((access-form + (ecase shift + (0 ;want a byte, indexed in bytes. + '((inst lc result base offset) + (when signed + (inst sl result 24) + (inst sar result 24)))) + (1 ;Want 16 bits. Incoming offset is in 16-bit quantities. + ;Offset here is in bytes. + '((if signed + (inst lha result base offset) + (inst lh result base offset)))) + (2 ;Want 32 bits. Incoming offset is in 32-bit quantities. + ;Offset here is in bytes. + '((loadw result base offset))))) + (name-c (symbolicate name "-C"))) + `(progn + (define-vop (,name-c) + (:policy :fast-safe) + (:translate ,translate) + (:args (base :scs (sap-reg))) + (:results (result :scs (,result-sc))) + (:result-types ,result-type) + (:arg-types system-area-pointer + (:constant (signed-byte ,(- 16 shift)))) + (:info offset) + (:variant-vars signed) + (:variant nil) + (:generator 5 + (let ((offset (ash offset ,shift))) + ,@access-form))) + + (define-vop (,name) + (:policy :fast-safe) + (:translate ,translate) + (:args (object :scs (sap-reg) :to :eval) + (offset :scs (any-reg) :target base)) + (:results (result :scs (,result-sc))) + (:arg-types system-area-pointer positive-fixnum) + (:result-types ,result-type) + (:temporary (:scs (sap-reg) :from (:argument 1)) base) + (:variant-vars signed) + (:variant nil) + (:generator 5 + (move base offset) + ;; + ;; We shift right because the offset has fixnum lowtag. Effectively + ;; the index has already been multiplied by 4. + ,@(let ((adj (- 2 shift))) + (unless (zerop adj) + `((inst sr base ,adj)))) + (inst a base object) + (let ((offset 0)) + ,@access-form))) + + ,@(when signed-translate + `((define-vop (,(symbolicate "SIGNED-" name-c) ,name-c) + (:translate ,signed-translate) + (:results (result :scs (,signed-result-sc))) + (:result-types ,signed-result-type) + (:variant t)) + + (define-vop (,(symbolicate "SIGNED-" name) ,name) + (:translate ,signed-translate) + (:results (result :scs (,signed-result-sc))) + (:result-types ,signed-result-type) + (:variant t))))))) + +) ;eval-when + +(define-system-ref 8bit-system-ref 0 + sap-ref-8 unsigned-reg positive-fixnum + signed-sap-ref-8 signed-reg tagged-num) + +(define-system-ref 16bit-system-ref 1 + sap-ref-16 unsigned-reg positive-fixnum + signed-sap-ref-16 signed-reg tagged-num) + +(define-system-ref 32bit-system-ref 2 + sap-ref-32 unsigned-reg unsigned-num + signed-sap-ref-32 signed-reg signed-num) + +(define-system-ref sap-system-ref 2 + sap-ref-sap sap-reg system-area-pointer) + + +(eval-when (compile eval) + +;;; DEFINE-SYSTEM-SET -- Internal. +;;; +;;; Name is the name of a computed system-ref offset, from which we generate a +;;; <name>-c VOP for immediate constant offsets. Shift is the multiples of two +;;; for which we must adjust the offset to make it an index in terms of bytes +;;; (the machines address units). Translate and signed-translate are the Lisp +;;; function calls for which these VOP's are in-line expansions. +;;; +(defmacro define-system-set (name shift translate data-scs data-type) + (let ((set-form + (ecase shift + (0 ;Want a byte. Incoming offset is in bytes. No shifting. + '(inst stc data base offset)) + (1 ;Want 16 bits. Incoming offset is in 16-bit quantities. + ;Offset here is in bytes. + '(inst sth data base offset)) + (2 ;Want 32 bits. Incoming offset is in 32-bit quantities. + ;Offset here is in bytes. + '(inst st data base offset)))) + (name-c (symbolicate name "-C"))) + `(progn + (define-vop (,name-c) + (:policy :fast-safe) + (:translate ,translate) + (:args (base :scs (sap-reg)) + (data :scs (,@data-scs) :target result :to (:result 0))) + (:arg-types system-area-pointer + ,data-type + (:constant (signed-byte ,(- 16 shift)))) + (:results (result :scs (,@data-scs))) + (:result-types ,data-type) + (:info offset) + (:generator 5 + (let ((offset (ash offset ,shift))) + ,set-form) + (move result data))) + + (define-vop (,name) + (:policy :fast-safe) + (:translate ,translate) + (:args (object :scs (sap-reg) :to (:eval 0)) + (offset :scs (any-reg) :target temp) + (data :scs (,@data-scs) :target result + :to (:result 0))) + (:arg-types system-area-pointer positive-fixnum ,data-type) + (:temporary (:scs (sap-reg) :from (:eval 0) :to (:result 0)) base) + (:temporary (:scs (non-descriptor-reg) + :from (:argument 1) :to (:eval 0)) temp) + (:results (result :scs (,@data-scs))) + (:result-types ,data-type) + (:generator 5 + (move temp offset) + ;; + ;; We shift right because the offset has fixnum lowtag. Effectively + ;; the index has already been multiplied by 4. + ,@(let ((adj (- 2 shift))) + (unless (zerop adj) + `((inst sr temp ,adj)))) + (inst cas base temp object) + (let ((offset 0)) + ,set-form) + (move result data)))))) + +) ;EVAL-WHEN + +(define-system-set 8bit-system-set 0 %set-sap-ref-8 + (signed-reg unsigned-reg) (:or signed-num unsigned-num)) + +(define-system-set 16bit-system-set 1 %set-sap-ref-16 + (signed-reg unsigned-reg) (:or signed-num unsigned-num)) + +(define-system-set 32bit-system-set 2 %set-sap-ref-32 + (signed-reg unsigned-reg) (:or signed-num unsigned-num)) + +(define-system-set sap-system-set 2 %set-sap-ref-sap + (sap-reg) system-area-pointer) + + + +;;;; Noise to convert normal lisp data objects into SAPs. + +(define-vop (vector-sap) + (:translate vector-sap) + (:policy :fast-safe) + (:args (vector :scs (descriptor-reg))) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst cal sap vector + (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type)))) + + + +;;;; ### Noise to allow old forms to continue to work until they are gone. + +(macrolet ((frob (prim func) + `(def-primitive-translator ,prim (&rest args) + (warn "Someone used %primitive ~S -- should be ~S." + ',prim ',func) + `(,',func ,@args)))) + (frob 32bit-system-ref sap-ref-32) + (frob unsigned-32bit-system-ref sap-ref-32) + (frob 16bit-system-ref sap-ref-16) + (frob 8bit-system-ref sap-ref-8)) + +(macrolet ((frob (prim func) + `(def-primitive-translator ,prim (&rest args) + (warn "Someone used %primitive ~S -- should be ~S." + ',prim (list 'setf ',func)) + `(setf ,',func ,@args)))) + (frob 32bit-system-set sap-ref-32) + (frob signed-32bit-system-set sap-ref-32) + (frob 16bit-system-set sap-ref-16) + (frob 8bit-system-set sap-ref-8)) diff --git a/compiler/rt/static-fn.lisp b/compiler/rt/static-fn.lisp new file mode 100644 index 0000000000000000000000000000000000000000..60045803a1baf0922acf226cc0df2f3ae962978b --- /dev/null +++ b/compiler/rt/static-fn.lisp @@ -0,0 +1,146 @@ +;;; -*- Package: C; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public +;;; domain. If you want to use this code or any part of CMU Common +;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/static-fn.lisp,v 1.1 1991/02/18 15:08:13 chiles Exp $ +;;; +;;; This file contains the VOPs and macro magic necessary to call static +;;; functions. +;;; +;;; Written by William Lott. +;;; Converted by Bill Chiles. +;;; + +(in-package "RT") + + + +(define-vop (static-function-template) + (:save-p t) + (:policy :safe) + (:variant-vars symbol) + (:vop-var vop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg)) move-temp) + (:temporary (:sc descriptor-reg :offset lra-offset) lra) + (:temporary (:sc descriptor-reg :offset cname-offset) cname) + (:temporary (:scs (interior-reg) :type interior) lip) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) old-fp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) + + +(eval-when (compile load eval) + +(defun static-function-template-name (num-args num-results) + (intern (format nil "~:@(~R-arg-~R-result-static-function~)" + num-args num-results))) + +(defun moves (dst src) + (collect ((moves)) + (do ((dst dst (cdr dst)) + (src src (cdr src))) + ((or (null dst) (null src))) + (moves `(move ,(car dst) ,(car src)))) + (moves))) + +(defun static-function-template-vop (num-args num-results) + (assert (and (<= num-args register-arg-count) + (<= num-results register-arg-count)) + (num-args num-results) + "Either too many args (~D) or too many results (~D). Max = ~D" + num-args num-results register-arg-count) + (let ((num-temps (max num-args num-results))) + (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) + (dotimes (i num-results) + (let ((result-name (intern (format nil "RESULT-~D" i)))) + (result-names result-name) + (results `(,result-name :scs (any-reg descriptor-reg))))) + (dotimes (i num-temps) + (let ((temp-name (intern (format nil "TEMP-~D" i)))) + (temp-names temp-name) + (temps `(:temporary (:sc descriptor-reg + :offset ,(nth i register-arg-offsets) + ,@(when (< i num-args) + `(:from (:argument ,i))) + ,@(when (< i num-results) + `(:to (:result ,i) + :target ,(nth i (result-names))))) + ,temp-name)))) + (dotimes (i num-args) + (let ((arg-name (intern (format nil "ARG-~D" i)))) + (arg-names arg-name) + (args `(,arg-name + :scs (any-reg descriptor-reg) + :target ,(nth i (temp-names)))))) + `(define-vop (,(static-function-template-name num-args num-results) + static-function-template) + (:args ,@(args)) + ,@(temps) + (:results ,@(results)) + (:generator ,(+ 50 num-args num-results) + (let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + ,@(moves (temp-names) (arg-names)) + (inst li nargs (fixnum ,num-args)) + (load-symbol cname symbol) + (loadw lip cname vm:symbol-raw-function-addr-slot + vm:other-pointer-type) + (when cur-nfp + (store-stack-tn cur-nfp nfp-save)) + (move old-fp cfp-tn) + (inst compute-lra-from-code lra code-tn lra-label) + (inst bx lip) + (inst move cfp-tn csp-tn) + (emit-return-pc lra-label) + (note-this-location vop :unknown-return) + ,(collect ((bindings) (links)) + (do ((temp (temp-names) (cdr temp)) + (name 'values (gensym)) + (prev nil name) + (i 0 (1+ i))) + ((= i num-results)) + (bindings `(,name + (make-tn-ref ,(car temp) nil))) + (when prev + (links `(setf (tn-ref-across ,prev) ,name)))) + `(let ,(bindings) + ,@(links) + (default-unknown-values + ,(if (zerop num-results) nil 'values) + ,num-results move-temp lra-label))) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + ,@(moves (result-names) (temp-names)))))))) + +) ;EVAL-WHEN (compile load eval) + + +(macrolet ((frob (nargs nres) + (static-function-template-vop nargs nres))) + (frob 0 1) + (frob 1 1) + (frob 2 1)) + +(defmacro define-static-function (name args &key (results '(x)) translate + policy cost arg-types result-types) + `(define-vop (,name + ,(static-function-template-name (length args) + (length results))) + (:variant ',name) + (:note ,(format nil "static-function ~@(~S~)" name)) + ,@(when translate + `((:translate ,translate))) + ,@(when policy + `((:policy ,policy))) + ,@(when cost + `((:generator-cost ,cost))) + ,@(when arg-types + `((:arg-types ,@arg-types))) + ,@(when result-types + `((:result-types ,@result-types))))) diff --git a/compiler/rt/subprim.lisp b/compiler/rt/subprim.lisp new file mode 100644 index 0000000000000000000000000000000000000000..2c9eb7942bd8c0e02813747d899d33ce695775b0 --- /dev/null +++ b/compiler/rt/subprim.lisp @@ -0,0 +1,63 @@ +;;; -*- Package: MIPS; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/subprim.lisp,v 1.1 1991/02/18 15:08:16 chiles Exp $ +;;; +;;; Linkage information for standard static functions, and random vops. +;;; +;;; Written by William Lott. +;;; Converted for IBM RT by Bill Chiles. +;;; + +(in-package "RT") + + + +;;;; Length + +(define-vop (length/list) + (:translate length) + (: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 (any-reg) :type fixnum :to (:result 0) :target result) + count) + (:results (result :scs (any-reg descriptor-reg))) + (:policy :fast-safe) + (: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) + (inst li count 0) + + (emit-label loop) + + (inst c ptr null-tn) + (inst bc :eq done) + + (test-type ptr temp not-list t vm:list-pointer-type) + + (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) + (inst inc count (fixnum 1)) + (test-type ptr temp loop nil vm:list-pointer-type) + + (cerror-call vop done object-not-list-error ptr) + + (emit-label done) + (move result count)))) + + +(define-static-function length (object) :translate length) + + + diff --git a/compiler/rt/system.lisp b/compiler/rt/system.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b3f3166b13cacf4680a0435906fa320c151c4451 --- /dev/null +++ b/compiler/rt/system.lisp @@ -0,0 +1,286 @@ +;;; -*- Package: rt; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/system.lisp,v 1.1 1991/02/18 15:08:18 chiles Exp $ +;;; +;;; IBM RT VM definitions of various system hacking operations. +;;; +;;; Written by Rob MacLachlan +;;; +;;; IBM RT conversion by Bill Chiles. +;;; + +(in-package "RT") + + + +;;;; Random pointer comparison VOPs + +(define-vop (pointer-compare) + (:args (x :scs (sap-reg)) + (y :scs (sap-reg))) + (:arg-types system-area-pointer system-area-pointer) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline comparison") + (:variant-vars condition) + (:generator 6 + (inst cl x y) + (if not-p + (inst bnc condition target) + (inst bc condition target)))) + +(macrolet ((frob (name cond) + `(progn + (def-primitive-translator ,name (x y) `(,',name ,x ,y)) + (defknown ,name (t t) boolean (movable foldable flushable)) + (define-vop (,name pointer-compare) + (:translate ,name) + (:variant ,cond))))) + (frob pointer< :lt) + (frob pointer> :gt)) + + + +;;;; Random assertions VOPS. + +(define-vop (check-op) + (:args (x :scs (any-reg descriptor-reg)) + (y :scs (any-reg descriptor-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:policy :fast-safe)) + +(define-vop (check<= check-op) + (:translate check<=) + (:generator 6 + (let ((target (generate-error-code vop not-<=-error x y))) + (inst c x y) + (inst bc :gt target)))) + +(define-vop (check= check-op) + (:translate check=) + (:generator 6 + (let ((target (generate-error-code vop not-=-error x y))) + (inst c x y) + (inst bnc :eq target)))) + + + +;;;; Type frobbing VOPs. + +(define-vop (get-lowtag) + (:translate get-lowtag) + (:policy :fast-safe) + (:args (object :scs (any-reg descriptor-reg))) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + (inst nilz result object lowtag-mask))) + +(define-vop (get-type) + (:translate get-type) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (let ((other-ptr (gen-label)) + (function-ptr (gen-label)) + (lowtag-only (gen-label)) + (done (gen-label))) + (test-type object ndescr other-ptr nil other-pointer-type) + (test-type object ndescr function-ptr nil function-pointer-type) + (test-type object ndescr lowtag-only nil + even-fixnum-type odd-fixnum-type list-pointer-type + structure-pointer-type) + (inst bx done) + (inst nilz result object type-mask) + + (emit-label function-ptr) + (load-type result object (- function-pointer-type)) + (inst b done) + + (emit-label lowtag-only) + (inst bx done) + (inst nilz result object lowtag-mask) + + (emit-label other-ptr) + (load-type result object (- other-pointer-type)) + + (emit-label done)))) + +(define-vop (get-header-data) + (:translate get-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 7 + (loadw res x 0 other-pointer-type) + (inst sr res type-bits))) + +(define-vop (get-closure-length) + (:translate get-closure-length) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 7 + (loadw res x 0 function-pointer-type) + (inst sr res type-bits))) + +;;; SET-HEADER-DATA -- VOP. +;;; +;;; In the immediate case for data, we use the OIL instruction assuming the +;;; data fits in the number of bits determined by 16 minus type-bits. Due to +;;; known uses of this VOP, which only store single digit tags, the above +;;; assumption is reasonable, although unnecessarily slimy. +;;; +(define-vop (set-header-data) + (:translate set-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg) :target res) + (data :scs (any-reg immediate) :target t2)) + (:arg-types * positive-fixnum) + (:results (res :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :type random) t1) + (:temporary (:scs (non-descriptor-reg) :type random :from (:argument 1)) t2) + (:generator 15 + (loadw t1 x 0 other-pointer-type) + (inst nilz t1 type-mask) + (sc-case data + (any-reg + (move t2 data) + ;; Since the data is in fixnum format, it is already shifted by 2 bits. + (inst sl t2 (- type-bits 2)) + (inst o t1 t2)) + (immediate + (let ((value (tn-value data))) + (unless (zerop value) + (inst oil t1 (ash value type-bits)))))) + (storew t1 x 0 other-pointer-type) + (move res x))) + +;;; MAKE-FIXNUM -- VOP. +;;; +;;; This is just used in hashing stuff. It doesn't necessarily have to +;;; preserve all the bits in the pointer. Some code expects a positive number, +;;; so make sure the right shift is logical. +;;; +(define-vop (make-fixnum) + (:args (ptr :scs (any-reg descriptor-reg) :target temp)) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 3 + (move temp ptr) + (inst sl temp 3) + (inst sr temp 1) + (move temp res))) + +(define-vop (make-other-immediate-type) + (:args (val :scs (any-reg descriptor-reg) :target vtemp) + (type :scs (any-reg descriptor-reg immediate))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) vtemp) + (:results (res :scs (any-reg descriptor-reg))) + (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:generator 2 + (sc-case type + (immediate + (move vtemp val) + (inst sl vtemp type-bits) + (inst oil res temp (tn-value type))) + (t + ;; Type is a fixnum, so lose those lowtag bits. + (move temp type) + (inst sr temp 2) + ;; Val is a fixnum, so we can shift it left two less bits. + (move res val) + (inst sl res (- type-bits 2)) + (inst o res temp))))) + + + +;;;; Allocation + +(define-vop (dynamic-space-free-pointer) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate dynamic-space-free-pointer) + (:policy :fast-safe) + (:generator 6 + (load-symbol-value int *allocation-pointer*))) + +(define-vop (binding-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate binding-stack-pointer-sap) + (:policy :fast-safe) + (:generator 6 + (load-symbol-value int *binding-stack-pointer*))) + +(define-vop (control-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate control-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move int csp-tn))) + + + +;;;; Code object frobbing. + +(define-vop (code-instructions) + (:args (code :scs (descriptor-reg) :target sap)) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 10 + (loadw ndescr code 0 other-pointer-type) + (inst sr ndescr type-bits) + (inst sl ndescr word-shift) + (inst s ndescr other-pointer-type) + (move sap code) + (inst a sap ndescr))) + +(define-vop (compute-function) + (:args (code :scs (descriptor-reg)) + (offset :scs (signed-reg unsigned-reg))) + (:arg-types * positive-fixnum) + (:results (func :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 10 + (loadw ndescr code 0 other-pointer-type) + (inst sr ndescr type-bits) + (inst sl ndescr word-shift) + (inst a ndescr offset) + (inst a ndescr (- function-pointer-type other-pointer-type)) + (inst a ndescr code) + (move func ndescr))) + + + +;;;; Other random VOPs. + + +(defknown mach::do-pending-interrupt () (values)) +(define-vop (mach::do-pending-interrupt) + (:policy :fast-safe) + (:translate mach::do-pending-interrupt) + (:generator 1 + (inst break pending-interrupt-trap))) + + +(define-vop (halt) + (:generator 1 + (inst break halt-trap))) + diff --git a/compiler/rt/type-vops.lisp b/compiler/rt/type-vops.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b16e5cbd22a776867181607c7347bdf6c6525846 --- /dev/null +++ b/compiler/rt/type-vops.lisp @@ -0,0 +1,468 @@ +;;; -*- Package: RT; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public +;;; domain. If you want to use this code or any part of CMU Common +;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/type-vops.lisp,v 1.1 1991/02/18 15:08:21 chiles Exp $ +;;; +;;; This file contains the VM definition of type testing and checking VOPs +;;; for the IBM RT. +;;; +;;; Written by William Lott. +;;; Converted to IBM RT by Bill Chiles. +;;; + +(in-package "RT") + + + +;;;; Simple type checking and testing. + +;;; These types are represented by a single type code and are easily open-coded +;;; as a mask and compare. +;;; + +;;; CHECK-TYPE -- VOP. +;;; +;;; Type checking VOPs include this. Instances of this either returns value +;;; in result, or they jump to error code if the type is wrong. +;;; +(define-vop (check-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)) + +;;; TYPE-PREDICATE -- VOP. +;;; +;;; Type predicate VOPs include this. They jump to target when value is of the +;;; appropriate type; otherwise, they drop through. When not-p is true, they +;;; drop through if value is of the type and jumps to target if not. +;;; +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:scs (non-descriptor-reg)) temp)) + + +(eval-when (compile eval) + +(defun cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) vm: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)))))) + +); eval-when (compile eval) + + +(def-type-vops fixnump check-fixnum nil object-not-fixnum-error + vm:even-fixnum-type vm:odd-fixnum-type) + +(def-type-vops functionp check-function function + object-not-function-error vm:function-pointer-type) + +(def-type-vops listp check-list list + object-not-list-error vm:list-pointer-type) + +(def-type-vops structurep check-structure structure + object-not-structure-error vm:structure-pointer-type) + +(def-type-vops bignump check-bigunm bignum + object-not-bignum-error vm:bignum-type) + +(def-type-vops ratiop check-ratio ratio + object-not-ratio-error vm:ratio-type) + +(def-type-vops complexp check-complex complex + object-not-complex-error vm:complex-type) + +(def-type-vops single-float-p check-single-float nil ;single-float + object-not-single-float-error vm:single-float-type) + +(def-type-vops double-float-p check-double-float nil ;double-float + object-not-double-float-error vm:double-float-type) + +(def-type-vops simple-string-p check-simple-string simple-string + object-not-simple-string-error vm:simple-string-type) + +(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector + object-not-simple-bit-vector-error vm:simple-bit-vector-type) + +(def-type-vops simple-vector-p check-simple-vector simple-vector + object-not-simple-vector-error vm: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 + vm: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 + vm: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 + vm: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 + vm: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 + vm: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 + vm: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 + vm:simple-array-double-float-type) + +(def-type-vops base-char-p check-base-character base-character + object-not-base-character-error vm:base-character-type) + +(def-type-vops system-area-pointer-p check-system-area-pointer + system-area-pointer object-not-sap-error vm:sap-type) + +(def-type-vops weak-pointer-p check-weak-pointer weak-pointer + object-not-weak-pointer-error vm:weak-pointer-type) + +(def-type-vops array-header-p nil nil nil + vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type + vm:complex-vector-type vm:complex-array-type) + +(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error + vm:function-pointer-type vm:symbol-header-type) + +(def-type-vops stringp check-string nil object-not-string-error + vm:simple-string-type vm:complex-string-type) + +(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error + vm:simple-bit-vector-type vm:complex-bit-vector-type) + +(def-type-vops vectorp check-vector nil 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) + +(def-type-vops simple-array-p check-simple-array nil 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) + +(def-type-vops arrayp check-array nil 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) + +(def-type-vops numberp check-number nil 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) + +(def-type-vops rationalp check-rational nil object-not-rational-error + vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) + +(def-type-vops integerp check-integer nil object-not-integer-error + vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type) + +(def-type-vops floatp check-float nil object-not-float-error + vm:single-float-type vm:double-float-type) + +(def-type-vops realp check-real nil 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) + + + +;;;; Other integer ranges. + +;;; A (signed-byte 32) can be represented with either fixnum or a bignum with +;;; exactly one digit. +;;; + +(define-vop (signed-byte-32-p 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)) + ;; Is it a fisnum? + (inst nilz temp value #x3) + (inst bc :eq yep) + ;; If not, is it an other pointer? + (test-type value temp nope t vm:other-pointer-type) + ;; If so, get the header. + (loadw temp value 0 vm:other-pointer-type) + ;; Is it a bignum of length one? + (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type)) + (if not-p + (inst bnc :eq target) + (inst bc :eq target)) + (emit-label not-target))))) + +(define-vop (check-signed-byte-32 check-type) + (:generator 45 + (let ((nope (generate-error-code vop object-not-signed-byte-32-error value)) + (yep (gen-label))) + (inst nilz temp value #x3) + (inst bc :eq yep) + (test-type value temp nope t vm:other-pointer-type) + (loadw temp value 0 vm:other-pointer-type) + (inst c temp + ;; Header word representing a bignum of length one. + (logior (ash 1 vm:type-bits) vm:bignum-type)) + (inst bnc :eq nope) + (emit-label yep) + (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 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 nilz temp value #x3) + (inst bcx :eq fixnum) + (inst c value 0) + ;; If not, is it an other pointer? + (test-type value temp nope t vm:other-pointer-type) + ;; Get the header. + (loadw temp value 0 vm:other-pointer-type) + ;; Is it a bignum of length one? + (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type)) + (inst bcx :eq single-word) + ;; If it length is other than two, we can't be an (unsigned-byte 32). + (inst c temp (+ (ash 2 vm:type-bits) vm:bignum-type)) + (inst bncx :eq nope) + ;; Get the second digit. + (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst c temp 0) + (inst bc :eq yep) + ;; Otherwise, it isn't. + (inst b nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw temp value vm:bignum-digits-offset vm:other-pointer-type) + (inst c temp 0) + + ;; positive implies (unsigned-byte 32). + (emit-label fixnum) + (if not-p + (inst bc :lt target) + (inst bnc :lt target)) + + (emit-label not-target))))) + +(define-vop (check-unsigned-byte-32 check-type) + (:generator 45 + (let ((nope + (generate-error-code vop object-not-unsigned-byte-32-error value)) + (yep (gen-label)) + (fixnum (gen-label)) + (single-word (gen-label))) + ;; Is it a fixnum? + (inst nilz temp value #x3) + (inst bcx :eq fixnum) + (inst c value 0) + + ;; If not, is it an other pointer? + (test-type value temp nope t vm:other-pointer-type) + ;; Get the number of digits. + (loadw temp value 0 vm:other-pointer-type) + ;; Is it one? + (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type)) + (inst bcx :eq single-word) + ;; If it's length is other than two, we can't be an (unsigned-byte 32). + (inst c temp (+ (ash 2 vm:type-bits) vm:bignum-type)) + (inst bncx :eq nope) + ;; Get the second digit. + (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst c temp 0) + (inst bc :eq yep) + ;; Otherwise, it isn't. + (inst bnc :eq nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw temp value vm:bignum-digits-offset vm:other-pointer-type) + ;; positive implies (unsigned-byte 32). + (inst c temp 0) + + (emit-label fixnum) + (inst bc :lt nope) + + (emit-label yep) + (move result value)))) + + + + +;;;; List/symbol types: + +;;; SYMBOLP -- VOP. +;;; +;;; This is (or symbol (eq nil)). +;;; +(define-vop (symbolp type-predicate) + (:translate symbolp) + (:generator 12 + (let* ((drop-thru (gen-label)) + (is-symbol-label (if not-p drop-thru target))) + (inst c value null-tn) + (inst bc :eq is-symbol-label) + (test-type value temp target not-p vm:symbol-header-type) + (emit-label drop-thru)))) +;;; +(define-vop (check-symbol check-type) + (:generator 12 + (let ((drop-thru (gen-label)) + (error (generate-error-code vop object-not-symbol-error value))) + (inst c value null-tn) + (inst bc :eq drop-thru) + (test-type value temp error t vm:symbol-header-type) + (emit-label drop-thru) + (move result value)))) + +;;; CONSP -- VOP. +;;; +;;; This is (and list (not (eq nil))). +;;; +(define-vop (consp type-predicate) + (:translate consp) + (:generator 8 + (let* ((drop-thru (gen-label)) + (is-not-cons-label (if not-p target drop-thru))) + (inst c value null-tn) + (inst bc :eq is-not-cons-label) + (test-type value temp target not-p vm:list-pointer-type) + (emit-label drop-thru)))) +;;; +(define-vop (check-cons check-type) + (:generator 8 + (let ((error (generate-error-code vop object-not-cons-error value))) + (inst c value null-tn) + (inst bc :eq error) + (test-type value temp error t vm:list-pointer-type) + (move result value)))) + + + +;;;; Function Coercion + +;;; If not a function, get the symbol value and test for that being a +;;; function. Since we test for a function rather than the unbound +;;; marker, this works on NIL. +;;; +(define-vop (coerce-to-function) + (:args (object :scs (descriptor-reg) + :target result)) + (:results (result :scs (descriptor-reg))) + (:temporary (:type random :scs (non-descriptor-reg)) nd-temp) + (:temporary (:scs (descriptor-reg)) saved-object) + (:vop-var vop) + (:save-p :compute-only) + (:generator 0 + (let ((not-function-label (gen-label)) + (not-coercable-label (gen-label)) + (done-label (gen-label))) + (test-type object nd-temp not-function-label t + vm:function-pointer-type) + (move result object) + (emit-label done-label) + + (assemble (*elsewhere*) + (emit-label not-function-label) + (test-type object nd-temp not-coercable-label t + vm:symbol-header-type) + (move saved-object object) + (loadw result object vm:symbol-function-slot vm:other-pointer-type) + (test-type result nd-temp done-label nil + vm:function-pointer-type) + (error-call vop undefined-symbol-error saved-object) + + (emit-label not-coercable-label) + (error-call vop object-not-coercable-to-function-error object))))) + +(define-vop (fast-safe-coerce-to-function) + (:args (object :scs (descriptor-reg) + :target result)) + (:results (result :scs (descriptor-reg))) + (:temporary (:type random :scs (non-descriptor-reg)) nd-temp) + (:temporary (:scs (descriptor-reg)) saved-object) + (:vop-var vop) + (:save-p :compute-only) + (:generator 10 + (let ((not-function-label (gen-label)) + (done-label (gen-label))) + (test-type object nd-temp not-function-label t vm:function-pointer-type) + (move result object) + (emit-label done-label) + + (assemble (*elsewhere*) + (emit-label not-function-label) + (move saved-object object) + (loadw result object vm:symbol-function-slot vm:other-pointer-type) + (test-type result nd-temp done-label nil vm:function-pointer-type) + (error-call vop undefined-symbol-error saved-object))))) diff --git a/compiler/rt/values.lisp b/compiler/rt/values.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a7123302b7d7f91ca0d29d2de95e4e19d5239883 --- /dev/null +++ b/compiler/rt/values.lisp @@ -0,0 +1,102 @@ +;;; -*- Package: RT; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/values.lisp,v 1.1 1991/02/18 15:08:26 chiles Exp $ +;;; +;;; This file contains the implementation of unknown-values VOPs. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted for IBM RT by Bill Chiles. +;;; + +(in-package "RT") + + + +(define-vop (reset-stack-pointer) + (:args (ptr :scs (any-reg))) + (:generator 1 + (move csp-tn ptr))) + +;;; PUSH-VALUES -- VOP. +;;; +;;; Push some values onto the stack, returning the start and number of values +;;; pushed as results. It is assumed that the Vals are wired to the standard +;;; argument locations. Nvals is the number of values to push. +;;; +;;; The generator cost is pseudo-random. We could get it right by defining a +;;; bogus SC that reflects the costs of the memory-to-memory moves for each +;;; operand, but this seems unworthwhile. +;;; +(define-vop (push-values) + (:args + (vals :more t)) + (:results + (start :scs (word-pointer-reg)) + (count :scs (any-reg))) + (:info nvals) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) + :to (:result 0) + :target start) + start-temp) + (:generator 20 + (move start-temp csp-tn) + (inst cal csp-tn csp-tn (* nvals word-bytes)) + (do ((val vals (tn-ref-across val)) + (i 0 (1+ i))) + ((null val)) + (let ((tn (tn-ref-tn val))) + (sc-case tn + (descriptor-reg + (storew tn start-temp i)) + (control-stack + (load-stack-tn temp tn) + (storew temp start-temp i))))) + (move start start-temp) + (inst li count (fixnum nvals)))) + + +;;; VALUES-LIST -- VOP. +;;; +;;; Push a list of values on the stack, returning Start and Count as used in +;;; unknown values continuations. +;;; +(define-vop (values-list) + (:args (arg :scs (descriptor-reg) :target list)) + (:arg-types list) + (:policy :fast-safe) + (:results (start :scs (word-pointer-reg)) + (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) + (: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 c list null-tn) + (inst bcx :eq done) + (loadw temp list cons-car-slot list-pointer-type) + (loadw list list cons-cdr-slot list-pointer-type) + (inst cal csp-tn csp-tn word-bytes) + (storew temp csp-tn -1) + (test-type list ndescr loop nil list-pointer-type) + (error-call vop bogus-argument-to-values-list-error list) + + (emit-label done) + (move csp-tn count) + (inst s count start)))) diff --git a/compiler/rt/vm.lisp b/compiler/rt/vm.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3b2a5d4b465ec2dabfe69906ce902e20ae258e30 --- /dev/null +++ b/compiler/rt/vm.lisp @@ -0,0 +1,652 @@ +;;; -*- Package: RT; Log: c.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public +;;; domain. If you want to use this code or any part of CMU Common +;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; This file contains the VM definition for the IBM RT. +;;; +;;; Written by William Lott, Rob Maclachlan, and Bill Chiles. +;;; + +(in-package "RT") + + + +;;;; SB and SC definition: + +(define-storage-base registers :finite :size 16) +(define-storage-base 68881-float-registers :finite :size 8) +(define-storage-base AFPA-float-registers :finite :size 64) +(define-storage-base FPA-float-registers :finite :size 16) +(define-storage-base control-stack :unbounded :size 8) +(define-storage-base non-descriptor-stack :unbounded :size 0) +;; These are constants in components. +(define-storage-base constant :non-packed) +;; Anything I can cookup out of nowhere and store somewhere. +(define-storage-base immediate-constant :non-packed) + +;;; +;;; Handy macro so we don't have to keep changing all the numbers whenever +;;; we insert a new storage class. +;;; +(defmacro define-storage-classes (&rest classes) + (do ((forms (list 'progn) + (let* ((class (car classes)) + (sc-name (car class)) + (constant-name (intern (concatenate 'simple-string + (string sc-name) + "-SC-NUMBER")))) + (list* `(define-storage-class ,sc-name ,index + ,@(cdr class)) + `(defconstant ,constant-name ,index) + `(export ',constant-name) + forms))) + (index 0 (1+ index)) + (classes classes (cdr classes))) + ((null classes) + (nreverse forms)))) + +(define-storage-classes + + ;; Non-immediate contstants in the constant pool + (constant constant) + + + (immediate immediate-constant) + (null immediate-constant) + + + ;; The control stack. (Scanned by GC) + (control-stack control-stack) + + ;; The non-descriptor stack SC's. + (signed-stack non-descriptor-stack) ; (signed-byte 32) + (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) + (base-character-stack non-descriptor-stack) ; non-descriptor characters. + (sap-stack non-descriptor-stack) ; System area pointers. + (single-stack non-descriptor-stack) ; single-floats + (double-stack non-descriptor-stack :element-size 2) ; double floats. + + + ;; **** Things that can go in the non-descriptor registers. + + ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing + ;; bad will happen if they are. (fixnums, characters, header values, etc). + (any-reg registers + :locations (0 2 3 4 9 10 11 12 13 14) + :constant-scs (immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Descriptor objects. Must be seen by GC. + (descriptor-reg registers + :locations (9 10 11 12 13 14) + ;; Immediate (and constant) for moving NULL around (at least). + :constant-scs (constant immediate null) + :save-p t + :alternate-scs (control-stack)) + + ;; Non-Descriptor characters. + (base-character-reg registers + :locations (0 2 3 4) + :constant-scs (immediate) + :save-p t + :alternate-scs (base-character-stack)) + + ;; Non-Descriptor SAP's (arbitrary pointers into address space). + (sap-reg registers + ;; Exclude R0 here because the instructions we would like to use with sap + ;; TN's use R0 as the constant zero instead of using the contents of R0. + :locations (2 3 4) + :constant-scs (immediate) + :save-p t + :alternate-scs (sap-stack)) + + ;; Non-Descriptor (signed or unsigned) numbers. + (signed-reg registers + :locations (0 2 3 4) + :constant-scs (immediate) + :save-p t + :alternate-scs (signed-stack)) + (unsigned-reg registers + :locations (0 2 3 4) + :constant-scs (immediate) + :save-p t + :alternate-scs (unsigned-stack)) + + ;; Random objects that must not be seen by GC. Used only as temporaries. + (non-descriptor-reg registers + :locations (0 2 3 4)) + + ;; Word-aligned pointers that cannot be in R0. Used only as temporaries. + (word-pointer-reg registers + :locations (2 3 4 9 10 11 12 13 14) + :save-p t + :alternate-scs (control-stack)) + + ;; Pointers to the interior of objects. Used only as an temporary. + (interior-reg registers + :locations (15)) + + + ;; **** Things that can go in the floating point registers. + + ;; Non-Descriptor 68881-single-floats. + (68881-single-reg 68881-float-registers + :locations (0 1 2 3 4 5 6 7) + :constant-scs (constant) + :save-p t + :alternate-scs (single-stack)) + ;; Non-Descriptor 68881-double-floats. + (68881-double-reg 68881-float-registers + :locations (0 1 2 3 4 5 6 7) + :constant-scs (constant) + :save-p t + :alternate-scs (double-stack)) + + ;; Non-Descriptor FPA-single-floats. + (FPA-single-reg FPA-float-registers + ;; 14 and 15 are status and exception registers. + :locations (0 1 2 3 4 5 6 7 8 9 10 11 12 13) + :constant-scs (constant) + :save-p t + :alternate-scs (single-stack)) + ;; Non-Descriptor FPA-double-floats. + (FPA-double-reg FPA-float-registers + :locations (0 2 4 6 8 10 12) ;14 and 15 are status and exception registers. + :element-size 2 + :constant-scs (constant) + :save-p t + :alternate-scs (double-stack)) + + ;; Non-Descriptor AFPA-single-floats. + (AFPA-single-reg AFPA-float-registers + :locations (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 + 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 + 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63) + :constant-scs (constant) + :save-p t + :alternate-scs (single-stack)) + ;; Non-Descriptor AFPA-double-floats. + (AFPA-double-reg AFPA-float-registers + :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 + 30 32 34 36 38 40 42 44 46 48 50 52 54 56 58 60 62) + :element-size 2 + :constant-scs (constant) + :save-p t + :alternate-scs (double-stack)) + + + ;; A catch or unwind block. + (catch-block control-stack :element-size vm:catch-block-size)) + + + + +;;;; Primitive Type Definitions + +;;; *any-primitive-type* +;;; +;;; Other VOP/VM definition files use this when writing interface code for the +;;; compiler. +;;; +(def-primitive-type t (descriptor-reg)) +(defvar *any-primitive-type* (primitive-type-or-lose 't)) +(setf (c:backend-any-primitive-type c:*target-backend*) + (c:primitive-type-or-lose 't)) + +;;; Primitive integer types that fit in registers. +;;; +(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg) + :type (unsigned-byte 29)) +(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg) + :type (unsigned-byte 31)) +(def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg) + :type (unsigned-byte 32)) +(def-primitive-type fixnum (any-reg signed-reg) + :type (signed-byte 30)) +(def-primitive-type signed-byte-32 (signed-reg descriptor-reg) + :type (signed-byte 32)) +(def-primitive-type word-pointer (word-pointer-reg descriptor-reg) + :type fixnum) + + +;;; *word-pointer-type* +;;; +(defvar *word-pointer-type* (primitive-type-or-lose 'word-pointer)) + + +;;; *fixnum-primitive-type* +;;; +;;; Other VOP/VM definition files use this when writing interface code for the +;;; compiler. +;;; +(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum)) + +(def-primitive-type-alias tagged-num (:or positive-fixnum fixnum)) +(def-primitive-type-alias unsigned-num (:or unsigned-byte-32 + unsigned-byte-31 + positive-fixnum)) +(def-primitive-type-alias signed-num (:or signed-byte-32 + fixnum + unsigned-byte-31 + positive-fixnum)) + +;;; Other primitive immediate types. +(def-primitive-type base-character (base-character-reg any-reg)) + +;;; Primitive pointer types. +;;; +(def-primitive-type function (descriptor-reg)) +(def-primitive-type list (descriptor-reg)) +(def-primitive-type structure (descriptor-reg)) + +;;; Primitive other-pointer number types. +;;; +(def-primitive-type bignum (descriptor-reg)) +(def-primitive-type ratio (descriptor-reg)) +(def-primitive-type complex (descriptor-reg)) +(def-primitive-type 68881-single-float (68881-single-reg descriptor-reg)) +(def-primitive-type 68881-double-float (68881-double-reg descriptor-reg)) +(def-primitive-type FPA-single-float (FPA-single-reg descriptor-reg)) +(def-primitive-type FPA-double-float (FPA-double-reg descriptor-reg)) +(def-primitive-type AFPA-single-float (AFPA-single-reg descriptor-reg)) +(def-primitive-type AFPA-double-float (AFPA-double-reg descriptor-reg)) +(def-primitive-type any-single-float (descriptor-reg)) +(def-primitive-type any-double-float (descriptor-reg)) + +;;; Primitive other-pointer array types. +;;; +(def-primitive-type simple-string (descriptor-reg) :type simple-base-string) +(def-primitive-type simple-bit-vector (descriptor-reg)) +(def-primitive-type simple-vector (descriptor-reg)) +(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg) + :type (simple-array (unsigned-byte 2) (*))) +(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg) + :type (simple-array (unsigned-byte 4) (*))) +(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg) + :type (simple-array (unsigned-byte 8) (*))) +(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg) + :type (simple-array (unsigned-byte 16) (*))) +(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg) + :type (simple-array (unsigned-byte 32) (*))) +(def-primitive-type simple-array-single-float (descriptor-reg) + :type (simple-array single-float (*))) +(def-primitive-type simple-array-double-float (descriptor-reg) + :type (simple-array double-float (*))) + +;;; Note: The complex array types are not included, because it is pointless to +;;; restrict VOPs to them. + +;;; Other primitive other-pointer types. +;;; +(def-primitive-type system-area-pointer (sap-reg descriptor-reg)) +(def-primitive-type weak-pointer (descriptor-reg)) + +;;; Random primitive types that don't exist at the LISP level. +;;; +(def-primitive-type random (non-descriptor-reg) :type nil) +(def-primitive-type interior (interior-reg) :type nil) +(def-primitive-type catch-block (catch-block) :type nil) + + + + +;;;; PRIMITIVE-TYPE-OF and friends. + +;;; PRIMITIVE-TYPE-OF -- Interface. +;;; +;;; Return the most restrictive primitive type that contains Object. +;;; +(def-vm-support-routine primitive-type-of (object) + (let ((type (ctype-of object))) + (cond ((not (member-type-p type)) (primitive-type type)) + ((equal (member-type-members type) '(nil)) + (primitive-type-or-lose 'list)) + (t + *any-primitive-type*)))) + +;;; +(defvar *simple-array-primitive-types* + '((base-character . simple-string) + (string-char . simple-string) + (bit . simple-bit-vector) + ((unsigned-byte 2) . simple-array-unsigned-byte-2) + ((unsigned-byte 4) . simple-array-unsigned-byte-4) + ((unsigned-byte 8) . simple-array-unsigned-byte-8) + ((unsigned-byte 16) . simple-array-unsigned-byte-16) + ((unsigned-byte 32) . simple-array-unsigned-byte-32) + (single-float . simple-array-single-float) + (double-float . simple-array-double-float) + (t . simple-vector)) + "An a-list for mapping simple array element types to their + corresponding primitive types.") + +(defvar *target-float-hardware* :MC68881 + "Describes the target float hardware. Values are :mc68881, :fpa, :afpa, + or :any for the RT.") + +;;; PRIMITIVE-TYPE -- Internal Interface. +;;; +;;; Return the primitive type corresponding to a type descriptor +;;; structure. The second value is true when the primitive type is +;;; exactly equivalent to the argument Lisp type. +;;; +;;; In a bootstrapping situation, we should be careful to use the +;;; correct values for the system parameters. +;;; +(def-vm-support-routine primitive-type (type) + (declare (type ctype type)) + (macrolet ((any () '(values *any-primitive-type* nil)) + (exactly (type) `(values (primitive-type-or-lose ',type) t)) + (part-of (type) `(values (primitive-type-or-lose ',type) nil))) + (etypecase type + (numeric-type + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (case (numeric-type-complexp type) + (:real + (case (numeric-type-class type) + (integer + (cond ((and hi lo) + (dolist (spec + '((positive-fixnum 0 #.(1- (ash 1 29))) + (unsigned-byte-31 0 #.(1- (ash 1 31))) + (unsigned-byte-32 0 #.(1- (ash 1 32))) + (fixnum #.(ash -1 29) #.(1- (ash 1 29))) + (signed-byte-32 #.(ash -1 31) + #.(1- (ash 1 31)))) + (if (or (< hi (ash -1 29)) + (> lo (1- (ash 1 29)))) + (part-of bignum) + (any))) + (let ((type (car spec)) + (min (cadr spec)) + (max (caddr spec))) + (when (<= min lo hi max) + (return (values (primitive-type-or-lose type) + (and (= lo min) (= hi max)))))))) + ((or (and hi (< hi most-negative-fixnum)) + (and lo (> lo most-positive-fixnum))) + (part-of bignum)) + (t + (any)))) + (float + (float-primitive-type lo hi type)) + (t + (any)))) + (:complex + (part-of complex)) + (t + (any))))) + (array-type + (if (array-type-complexp type) + (any) + (let* ((dims (array-type-dimensions type)) + (etype (array-type-specialized-element-type type)) + (type-spec (type-specifier etype)) + (ptype (cdr (assoc type-spec *simple-array-primitive-types* + :test #'equal)))) + (if (and (consp dims) (null (rest dims)) ptype) + (values (primitive-type-or-lose ptype) (eq (first dims) '*)) + (any))))) + (union-type + (if (type= type (specifier-type 'list)) + (exactly list) + (let ((types (union-type-types type))) + (multiple-value-bind (res exact) + (primitive-type (first types)) + (dolist (type (rest types) (values res exact)) + (multiple-value-bind (ptype ptype-exact) + (primitive-type type) + (unless ptype-exact (setq exact nil)) + (unless (eq ptype res) + (return (any))))))))) + (member-type + (let* ((members (member-type-members type)) + (res (primitive-type-of (first members)))) + (dolist (mem (rest members) (values res nil)) + (unless (eq (primitive-type-of mem) res) + (return (values *any-primitive-type* nil)))))) + (named-type + (case (named-type-name type) + ((t bignum ratio complex function system-area-pointer weak-pointer) + (values (primitive-type-or-lose (named-type-name type)) t)) + ((character base-character string-char) + (exactly base-character)) + (standard-char + (part-of base-character)) + (cons + (part-of list)) + (t + (any)))) + (ctype + (any))))) + +;;; FLOAT-PRIMITIVE-TYPE -- Internal. +;;; +(defun float-primitive-type (lo hi type) + (let ((exact (and (null lo) (null hi)))) + (case (numeric-type-format type) + ((short-float single-float) + (ecase *target-float-hardware* + (:mc68881 + (values (primitive-type-or-lose '68881-single-float) exact)) + (:fpa + (values (primitive-type-or-lose 'fpa-single-float) exact)) + (:afpa + (values (primitive-type-or-lose 'afpa-single-float) exact)) + (:any + (values (primitive-type-or-lose 'any-single-float) exact)))) + ((double-float long-float) + (ecase *target-float-hardware* + (:mc68881 + (values (primitive-type-or-lose '68881-double-float) exact)) + (:fpa + (values (primitive-type-or-lose 'fpa-double-float) exact)) + (:afpa + (values (primitive-type-or-lose 'afpa-double-float) exact)) + (:any + (values (primitive-type-or-lose 'any-double-float) exact)))) + (t + (values *any-primitive-type* nil))))) + + + +;;;; Magical Registers + +;;; Other VOP/VM definition files use the definitions on this page when writing +;;; interface code for the compiler. +;;; + +(eval-when (compile eval load) + (defconstant nargs-offset 0) + (defconstant nsp-offset 1) + (defconstant nl0-offset 2) + (defconstant ocfp-offset 3) + (defconstant nfp-offset 4) + (defconstant csp-offset 5) + (defconstant cfp-offset 6) + (defconstant code-offset 7) + (defconstant null-offset 8) + (defconstant cname-offset 9) + (defconstant lexenv-offset 10) + (defconstant lra-offset 11) + (defconstant a0-offset 12) + (defconstant a1-offset 13) + (defconstant a2-offset 14) + (defconstant lip-offset 15)) + +;;; Lisp-interior-pointer register. +;;; +(defparameter lip-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'any-reg) + :offset lip-offset)) + +;;; Nil. +;;; +(defparameter null-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset null-offset)) + + +;;; Frame Pointer. +;;; +(defparameter cfp-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'any-reg) + :offset cfp-offset)) + + +;;; Control stack pointer. +;;; +(defparameter csp-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'any-reg) + :offset csp-offset)) + +;;; Number stack pointer. +;;; +(defparameter nsp-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'any-reg) + :offset nsp-offset)) + +;;; Code Pointer. +;;; +(defparameter code-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'any-reg) + :offset code-offset)) + + + +;;;; Side-Effect Classes + +(def-boolean-attribute vop + any) + + +;;;; Constants + +;;; IMMEDIATE-CONSTANT-SC -- Interface. +;;; +;;; If value can be represented as an immediate constant, then return the +;;; appropriate SC number, otherwise return NIL. +;;; +(def-vm-support-routine immediate-constant-sc (value) + (typecase value + ((or fixnum character system-area-pointer) + (sc-number-or-lose 'immediate)) + (null + (sc-number-or-lose 'null)) + (symbol + (if (static-symbol-p value) + (sc-number-or-lose 'immediate) + nil)))) + + + +;;;; Function Call Parameters + +;;; The SC numbers for register and stack arguments/return values. +;;; +;;; Other VOP/VM definition files use this when writing interface code for the +;;; compiler. +;;; +(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) +(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) +(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) + + +(eval-when (compile load eval) + +;;; Offsets of special stack frame locations. +;;; +(defconstant ocfp-save-offset 0) +(defconstant lra-save-offset 1) +(defconstant nfp-save-offset 2) + +); Eval-When (Compile Load Eval) + + +(defparameter nargs-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'any-reg) + :offset nargs-offset)) + +(defparameter ocfp-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset ocfp-offset)) + +(defparameter lra-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset lra-offset)) + + +(eval-when (compile load eval) + +;;; The number of arguments/return values passed in registers. +;;; +;;; Other VOP/VM definition files use this when writing interface code for the +;;; compiler. +;;; +(defconstant register-arg-count 3) + +;;; The offsets within the register-arg SC where we supply values, first value +;;; first. +;;; +;;; Other VOP/VM definition files use this when writing interface code for the +;;; compiler. +;;; +(defconstant register-arg-offsets '(12 13 14)) + +;;; Names to use for the argument registers. +;;; +(defconstant register-arg-names '(a0 a1 a2)) + +); Eval-When (Compile Load Eval) + + +;;; A list of TN's describing the register arguments. +;;; +(defparameter register-arg-tns + (mapcar #'(lambda (n) + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset n)) + register-arg-offsets)) + + + +;;;; LOCATION-PRINT-NAME. + +(defconstant register-names #("NARGS" "NSP" "NL0" "OCFP" "NFP" + "CSP" "CFP" "CODE" "NULL" "CNAME" "LEXENV" + "LRA" "A0" "A1" "A2" "LIP")) + +;;; LOCATION-PRINT-NAME -- Interface. +;;; +;;; This function is called by debug output routines that want a pretty name +;;; for a TN's location. It returns a thing that can be printed with PRINC. +;;; +(def-vm-support-routine location-print-name (tn) + (declare (type tn tn)) + (let ((sb (sb-name (sc-sb (tn-sc tn)))) + (offset (tn-offset tn))) + (ecase sb + (registers (svref register-names (tn-offset tn))) + ((68881-float-registers FPA-float-registers AFPA-float-registers) + (format nil "F~D" offset)) + (control-stack (format nil "CS~D" offset)) + (non-descriptor-stack (format nil "NS~D" offset)) + (constant (format nil "Const~D" offset)) + (immediate-constant "Immed"))))