X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsparc%2Fvm.lisp;h=f50443b8faaea4e11967b3ba30fb451126fe47ed;hb=HEAD;hp=e2d549a5326ad4875067c50afd92d707d531f1ce;hpb=4ed3f0d08c3a57a6762018d9622f253ab9d0f2b6;p=sbcl.git diff --git a/src/compiler/sparc/vm.lisp b/src/compiler/sparc/vm.lisp index e2d549a..f50443b 100644 --- a/src/compiler/sparc/vm.lisp +++ b/src/compiler/sparc/vm.lisp @@ -10,69 +10,80 @@ ;;;; files for more information. (in-package "SB!VM") - + +;;;; Additional constants + +;;; NUMBER-STACK-DISPLACEMENT +;;; +;;; The number of bytes reserved above the number stack pointer. These +;;; slots are required by architecture for a place to spill register windows. +;;; +;;; FIXME: Where is this used? +(def!constant number-stack-displacement + (* 16 n-word-bytes)) + ;;;; Define the registers (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *register-names* (make-array 32 :initial-element nil))) (macrolet ((defreg (name offset) - (let ((offset-sym (symbolicate name "-OFFSET"))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (def!constant ,offset-sym ,offset) - (setf (svref *register-names* ,offset-sym) - ,(symbol-name name))))) - - (defregset (name &rest regs) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,name - (list ,@(mapcar (lambda (name) - (symbolicate name "-OFFSET")) - regs)))))) + (let ((offset-sym (symbolicate name "-OFFSET"))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (def!constant ,offset-sym ,offset) + (setf (svref *register-names* ,offset-sym) + ,(symbol-name name))))) + + (defregset (name &rest regs) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,name + (list ,@(mapcar (lambda (name) + (symbolicate name "-OFFSET")) + regs)))))) ;; c.f. src/runtime/sparc-lispregs.h ;; Globals. These are difficult to extract from a sigcontext. - (defreg zero 0) ; %g0 - (defreg alloc 1) ; %g1 - (defreg null 2) ; %g2 - (defreg csp 3) ; %g3 - (defreg cfp 4) ; %g4 - (defreg bsp 5) ; %g5 + (defreg zero 0) ; %g0 + (defreg alloc 1) ; %g1 + (defreg null 2) ; %g2 + (defreg csp 3) ; %g3 + (defreg cfp 4) ; %g4 + (defreg bsp 5) ; %g5 ;; %g6 and %g7 are supposed to be reserved for the system. ;; Outs. These get clobbered when we call into C. - (defreg nl0 8) ; %o0 - (defreg nl1 9) ; %o1 - (defreg nl2 10) ; %o2 - (defreg nl3 11) ; %o3 - (defreg nl4 12) ; %o4 - (defreg nl5 13) ; %o5 - (defreg nsp 14) ; %o6 - (defreg nargs 15) ; %o7 + (defreg nl0 8) ; %o0 + (defreg nl1 9) ; %o1 + (defreg nl2 10) ; %o2 + (defreg nl3 11) ; %o3 + (defreg nl4 12) ; %o4 + (defreg nl5 13) ; %o5 + (defreg nsp 14) ; %o6 + (defreg nargs 15) ; %o7 ;; Locals. These are preserved when we call into C. - (defreg a0 16) ; %l0 - (defreg a1 17) ; %l1 - (defreg a2 18) ; %l2 - (defreg a3 19) ; %l3 - (defreg a4 20) ; %l4 - (defreg a5 21) ; %l5 - (defreg ocfp 22) ; %l6 - (defreg lra 23) ; %l7 + (defreg a0 16) ; %l0 + (defreg a1 17) ; %l1 + (defreg a2 18) ; %l2 + (defreg a3 19) ; %l3 + (defreg a4 20) ; %l4 + (defreg a5 21) ; %l5 + (defreg ocfp 22) ; %l6 + (defreg lra 23) ; %l7 ;; Ins. These are preserved just like locals. - (defreg cname 24) ; %i0 - (defreg lexenv 25) ; %i1 - (defreg l0 26) ; %i2 - (defreg nfp 27) ; %i3 - (defreg cfunc 28) ; %i4 - (defreg code 29) ; %i5 + (defreg cname 24) ; %i0 + (defreg lexenv 25) ; %i1 + (defreg l0 26) ; %i2 + (defreg nfp 27) ; %i3 + (defreg cfunc 28) ; %i4 + (defreg code 29) ; %i5 ;; we can't touch reg 30 if we ever want to return - (defreg lip 31) ; %i7 + (defreg lip 31) ; %i7 (defregset non-descriptor-regs nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp) - + (defregset descriptor-regs a0 a1 a2 a3 a4 a5 ocfp lra cname lexenv l0) @@ -92,14 +103,14 @@ ;;; 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)) - `(def!constant ,constant-name ,index) + (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)) + `(def!constant ,constant-name ,index) ;; (The CMU CL version of this macro did ;; `(EXPORT ',CONSTANT-NAME) ;; here, but in SBCL we try to have package @@ -107,7 +118,7 @@ ;; master source file, instead of building it ;; dynamically by letting all the system code ;; modify it as the system boots.) - forms))) + forms))) (index 0 (1+ index)) (classes classes (cdr classes))) ((null classes) @@ -118,7 +129,7 @@ ;;; and seems to be working so far -dan ;;; ;;; arbitrarily taken for alpha, too. - Christophe -(def!constant kludge-nondeterministic-catch-block-size 7) +(def!constant kludge-nondeterministic-catch-block-size 6) (!define-storage-classes @@ -139,14 +150,35 @@ ;; The control stack. (Scanned by GC) (control-stack control-stack) + ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER + ;; is small and therefore the error trap information is smaller. + ;; Moving them up here from their previous place down below saves + ;; ~250K in core file size. --njf, 2006-01-27 + + ;; 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 #.(append non-descriptor-regs descriptor-regs) + :constant-scs (zero immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Pointer descriptor objects. Must be seen by GC. + (descriptor-reg registers + :locations #.descriptor-regs + :constant-scs (constant null immediate) + :save-p t + :alternate-scs (control-stack)) + ;; The non-descriptor stacks. (signed-stack non-descriptor-stack) ; (signed-byte 32) (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) - (base-char-stack non-descriptor-stack) ; non-descriptor characters. + (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 :alignment 2) ; double floats. + :element-size 2 :alignment 2) ; double floats. #!+long-float (long-stack non-descriptor-stack :element-size 4 :alignment 4) ; long floats. ;; complex-single-floats @@ -160,28 +192,12 @@ ;; **** Things that can go in the integer 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 #.(append non-descriptor-regs descriptor-regs) - :constant-scs (zero immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; Pointer descriptor objects. Must be seen by GC. - (descriptor-reg registers - :locations #.descriptor-regs - :constant-scs (constant null immediate) - :save-p t - :alternate-scs (control-stack)) - ;; Non-Descriptor characters - (base-char-reg registers + (character-reg registers :locations #.non-descriptor-regs :constant-scs (immediate) :save-p t - :alternate-scs (base-char-stack)) + :alternate-scs (character-stack)) ;; Non-Descriptor SAP's (arbitrary pointers into address space) (sap-reg registers @@ -224,7 +240,7 @@ ;; Non-Descriptor double-floats. (double-reg float-registers :locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63 - by 2 collect i) + by 2 collect i) :element-size 2 :alignment 2 :reserve-locations (28 30) :constant-scs () @@ -235,7 +251,7 @@ #!+long-float (long-reg float-registers :locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63 - by 4 collect i) + by 4 collect i) :element-size 4 :alignment 4 :reserve-locations (28) :constant-scs () @@ -252,7 +268,7 @@ (complex-double-reg float-registers :locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63 - by 4 collect i) + by 4 collect i) :element-size 4 :alignment 4 :reserve-locations (28) :constant-scs () @@ -262,7 +278,7 @@ #!+long-float (complex-long-reg float-registers :locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63 - by 8 collect i) + by 8 collect i) :element-size 8 :alignment 8 :constant-scs () :save-p t @@ -274,17 +290,18 @@ ;;;; Make some miscellaneous TNs for important registers. (macrolet ((defregtn (name sc) - (let ((offset-sym (symbolicate name "-OFFSET")) - (tn-sym (symbolicate name "-TN"))) - `(defparameter ,tn-sym - (make-random-tn :kind :normal - :sc (sc-or-lose ',sc) - :offset ,offset-sym))))) + (let ((offset-sym (symbolicate name "-OFFSET")) + (tn-sym (symbolicate name "-TN"))) + `(defparameter ,tn-sym + (make-random-tn :kind :normal + :sc (sc-or-lose ',sc) + :offset ,offset-sym))))) (defregtn zero any-reg) (defregtn null descriptor-reg) (defregtn code descriptor-reg) + (defregtn lip descriptor-reg) (defregtn alloc any-reg) - + (defregtn nargs any-reg) (defregtn bsp any-reg) (defregtn csp any-reg) @@ -294,18 +311,24 @@ ;;; 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) +(defun immediate-constant-sc (value) (typecase value ((integer 0 0) (sc-number-or-lose 'zero)) (null (sc-number-or-lose 'null)) - ((or fixnum system-area-pointer character) + ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum) + character) (sc-number-or-lose 'immediate)) (symbol (if (static-symbol-p value) - (sc-number-or-lose 'immediate) - nil)))) + (sc-number-or-lose 'immediate) + nil)))) + +(defun boxed-immediate-sc-p (sc) + (or (eql sc (sc-number-or-lose 'zero)) + (eql sc (sc-number-or-lose 'null)) + (eql sc (sc-number-or-lose 'immediate)))) ;;;; function call parameters @@ -332,10 +355,10 @@ ;;; 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*)) + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset n)) + *register-arg-offsets*)) ;;; This is used by the debugger. (def!constant single-value-return-byte-offset 8) @@ -343,23 +366,23 @@ ;;; 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) +(defun location-print-name (tn) (declare (type tn tn)) ; FIXME: commented out on alpha (let ((sb (sb-name (sc-sb (tn-sc tn)))) - (offset (tn-offset tn))) + (offset (tn-offset tn))) (ecase sb (registers (or (svref *register-names* offset) - (format nil "R~D" offset))) + (format nil "R~D" offset))) (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")))) - -;;; The loader uses this to convert alien names to the form they -;;; occure in the symbol table (for example, prepending an -;;; underscore). On the SPARC, we don't prepend an underscore. -(defun extern-alien-name (name) - (declare (type simple-base-string name)) - (concatenate 'string #+nil "_" name)) +(defun combination-implementation-style (node) + (declare (type sb!c::combination node) (ignore node)) + (values :default nil)) + +(defun primitive-type-indirect-cell-type (ptype) + (declare (ignore ptype)) + nil)