X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Fvm.lisp;h=7f1bc96cb78a0be3e0a135722a31da72aaf6848c;hb=f21e0f5b908263715ea0d867edb64ceba5a3d668;hp=fa8a2bf709e5f5845d6b9be593fc289c82186082;hpb=d1441ffce0db0043ccbcb27fa5ab590e44a85994;p=sbcl.git diff --git a/src/compiler/ppc/vm.lisp b/src/compiler/ppc/vm.lisp index fa8a2bf..7f1bc96 100644 --- a/src/compiler/ppc/vm.lisp +++ b/src/compiler/ppc/vm.lisp @@ -16,7 +16,7 @@ ;;; The number of bytes reserved above the number stack pointer. These ;;; slots are required by architecture, mostly (?) to make C backtrace ;;; work. This must be a power of 2 - see BYTES-REQUIRED-FOR-NUMBER-STACK. -;;; +;;; (def!constant number-stack-displacement (* #!-darwin 2 #!+darwin 8 @@ -32,7 +32,7 @@ `(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 @@ -49,7 +49,7 @@ (defreg nl4 7) (defreg nl5 8) (defreg nl6 9) - (defreg fdefn 10) ; was nl7 + (defreg fdefn 10) ; was nl7 (defreg nargs 11) ;; FIXME: some kind of comment here would be nice. ;; @@ -74,16 +74,16 @@ (defreg a3 27) (defreg l0 28) (defreg l1 29) - (defreg l2 30) + (defreg #!-sb-thread l2 #!+sb-thread thread 30) (defreg lip 31) (defregset non-descriptor-regs nl0 nl1 nl2 nl3 nl4 nl5 nl6 #+nil nl7 cfunc nargs nfp) - + (defregset descriptor-regs - fdefn a0 a1 a2 a3 ocfp lra cname lexenv l0 l1 l2 ) + fdefn a0 a1 a2 a3 ocfp lra cname lexenv l0 l1 #!-sb-thread l2 ) + - (defregset *register-arg-offsets* a0 a1 a2 a3) (defparameter register-arg-names '(a0 a1 a2 a3))) @@ -101,24 +101,24 @@ ;;; ;;; 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)) - `(def!constant ,constant-name ,index) - forms))) + (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) + forms))) (index 0 (1+ index)) (classes classes (cdr classes))) ((null classes) (nreverse forms)))) -(def!constant kludge-nondeterministic-catch-block-size 7) +(def!constant kludge-nondeterministic-catch-block-size 6) (define-storage-classes @@ -138,19 +138,10 @@ ;; The control stack. (Scanned by GC) (control-stack 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. - (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. - (complex-single-stack non-descriptor-stack :element-size 2) - (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) - - - ;; **** Things that can go in the integer registers. + ;; 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). @@ -168,12 +159,26 @@ :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) + (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. + (complex-single-stack non-descriptor-stack :element-size 2) + (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) + + + ;; **** Things that can go in the integer registers. + ;; 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 @@ -256,7 +261,9 @@ (defregtn null descriptor-reg) (defregtn code descriptor-reg) (defregtn alloc any-reg) - + (defregtn lra descriptor-reg) + (defregtn lexenv descriptor-reg) + (defregtn nargs any-reg) (defregtn bsp any-reg) (defregtn csp any-reg) @@ -272,12 +279,26 @@ (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)))) + +(!def-vm-support-routine 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)))) + +;;; A predicate to see if a character can be used as an inline +;;; constant (the immediate field in the instruction used is sixteen +;;; bits wide, which is not the same as any defined subtype of +;;; CHARACTER). +(defun inlinable-character-constant-p (char) + (and (characterp char) + (< (char-code char) #x10000))) ;;;; function call parameters @@ -306,10 +327,15 @@ ;;; (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*)) + +#!+sb-thread +(defparameter thread-base-tn + (make-random-tn :kind :normal :sc (sc-or-lose 'unsigned-reg) + :offset thread-offset)) (export 'single-value-return-byte-offset) @@ -321,22 +347,59 @@ (!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))) + (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 -;;; occur in the symbol table. This is ELF, so do nothing. - -(defun extern-alien-name (name) - (declare (type simple-base-string name)) - ;; Darwin is non-ELF, and needs a _ prefix - #!+darwin (concatenate 'string "_" name) - ;; The other (ELF) ports currently don't need any prefix - #!-darwin name) + +(!def-vm-support-routine combination-implementation-style (node) + (declare (type sb!c::combination node)) + (flet ((valid-funtype (args result) + (sb!c::valid-fun-use node + (sb!c::specifier-type + `(function ,args ,result))))) + (case (sb!c::combination-fun-source-name node) + (logtest + (cond + ((or (valid-funtype '(fixnum fixnum) '*) + (valid-funtype '((signed-byte 32) (signed-byte 32)) '*) + (valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*)) + (values :maybe nil)) + (t (values :default nil)))) + (logbitp + (cond + ((or (valid-funtype '((constant-arg (integer 0 29)) fixnum) '*) + (valid-funtype '((constant-arg (integer 0 31)) (signed-byte 32)) '*) + (valid-funtype '((constant-arg (integer 0 31)) (unsigned-byte 32)) '*)) + (values :transform '(lambda (index integer) + (%logbitp integer index)))) + (t (values :default nil)))) + ;; FIXME: can handle MIN and MAX here + (sb!kernel:%ldb + (flet ((validp (type width) + (and (valid-funtype `((constant-arg (integer 1 29)) + (constant-arg (mod ,width)) + ,type) + 'fixnum) + (destructuring-bind (size posn integer) + (sb!c::basic-combination-args node) + (declare (ignore integer)) + (<= (+ (sb!c::lvar-value size) + (sb!c::lvar-value posn)) + width))))) + (if (or (validp 'fixnum 29) + (validp '(signed-byte 32) 32) + (validp '(unsigned-byte 32) 32)) + (values :transform '(lambda (size posn integer) + (%%ldb integer size posn))) + (values :default nil)))) + (t (values :default nil))))) + +(defun primitive-type-indirect-cell-type (ptype) + (declare (ignore ptype)) + nil)