X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Fvm.lisp;h=732184b25292d37e31bb7fcb4e9b19d97bf9ca1d;hb=51344a3364f2cd6b14985719a77f697c094ea14d;hp=2b0a7cd88f6d4321bc69273f5c353eacfc574591;hpb=c94a9f9d1be535ce5df6127cce722d3edd9a6345;p=sbcl.git diff --git a/src/compiler/ppc/vm.lisp b/src/compiler/ppc/vm.lisp index 2b0a7cd..732184b 100644 --- a/src/compiler/ppc/vm.lisp +++ b/src/compiler/ppc/vm.lisp @@ -1,6 +1,26 @@ -;;; +;;;; miscellaneous VM definition noise for the PPC + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + (in-package "SB!VM") +;;; NUMBER-STACK-DISPLACEMENT +;;; +;;; 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 + n-word-bytes)) ;;;; Define the registers @@ -12,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 @@ -29,10 +49,15 @@ (defreg nl4 7) (defreg nl5 8) (defreg nl6 9) - (defreg fdefn 10) ; was nl7 + (defreg fdefn 10) ; was nl7 (defreg nargs 11) - (defreg nfp 12) - (defreg cfunc 13) + ;; FIXME: some kind of comment here would be nice. + ;; + ;; FIXME II: this also reveals the need to autogenerate lispregs.h + #!+darwin (defreg cfunc 12) + #!-darwin (defreg nfp 12) + #!+darwin (defreg nfp 13) + #!-darwin (defreg cfunc 13) (defreg bsp 14) (defreg cfp 15) (defreg csp 16) @@ -54,11 +79,11 @@ (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 ) - + (defregset *register-arg-offsets* a0 a1 a2 a3) (defparameter register-arg-names '(a0 a1 a2 a3))) @@ -76,26 +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)))) -;; XXX this is most likely wrong. Check with Eric Marsden next time you -;; see him -(def!constant sb!vm::kludge-nondeterministic-catch-block-size 7) +(def!constant kludge-nondeterministic-catch-block-size 7) (define-storage-classes @@ -115,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). @@ -145,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 @@ -216,9 +244,7 @@ ;; A catch or unwind block. (catch-block control-stack - :element-size sb!vm::kludge-nondeterministic-catch-block-size)) - - + :element-size kludge-nondeterministic-catch-block-size)) ;;;; Make some random tns for important registers. @@ -235,100 +261,121 @@ (defregtn null descriptor-reg) (defregtn code descriptor-reg) (defregtn alloc any-reg) - + (defregtn nargs any-reg) (defregtn bsp any-reg) (defregtn csp any-reg) (defregtn cfp any-reg) (defregtn ocfp any-reg) (defregtn nsp any-reg)) - - -;;; Immediate-Constant-SC -- Interface -;;; -;;; If value can be represented as an immediate constant, then return the +;;; 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 ((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) + system-area-pointer character) (sc-number-or-lose 'immediate)) (symbol (if (static-symbol-p value) - (sc-number-or-lose 'immediate) - nil)))) - + (sc-number-or-lose 'immediate) + nil)))) -;;;; Function Call Parameters +;;;; function call parameters -;;; The SC numbers for register and stack arguments/return values. -;;; +;;; the SC numbers for register and stack arguments/return values (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) (def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) (eval-when (:compile-toplevel :load-toplevel :execute) -;;; Offsets of special stack frame locations +;;; offsets of special stack frame locations (def!constant ocfp-save-offset 0) (def!constant lra-save-offset 1) (def!constant nfp-save-offset 2) -;;; The number of arguments/return values passed in registers. -;;; +;;; the number of arguments/return values passed in registers (def!constant register-arg-count 4) -;;; Names to use for the argument registers. -;;; +;;; names to use for the argument registers -); Eval-When (:compile-toplevel :load-toplevel :execute) +) ; EVAL-WHEN ;;; 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*)) (export 'single-value-return-byte-offset) -;;; SINGLE-VALUE-RETURN-BYTE-OFFSET -;;; ;;; This is used by the debugger. -;;; (def!constant single-value-return-byte-offset 8) - -;;; LOCATION-PRINT-NAME -- Interface -;;; -;;; This function is called by debug output routines that want a pretty name +;;; 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))) + (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)) - 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 :direct 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 + (cond + ((or (valid-funtype '((constant-arg (integer 1 29)) + (constant-arg (integer 0 29)) + fixnum) + 'fixnum) + (valid-funtype '((constant-arg (integer 1 29)) + (constant-arg (integer 0 29)) + (signed-byte 32)) + 'fixnum) + (valid-funtype '((constant-arg (integer 1 29)) + (constant-arg (integer 0 29)) + (unsigned-byte 32)) + 'fixnum)) + (values :transform + '(lambda (size posn integer) + (%%ldb integer size posn)))) + (t (values :default nil)))) + (t (values :default nil)))))