X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fhppa%2Fvm.lisp;h=28f1db25d32bcf564e74fbcc7269708149791221;hb=debae3c18d31b5222be4d5de8dcb2601336e24a4;hp=3a2477a883633b512e697a3e9c00ee5600332589;hpb=8a19c6876412b8ad1cf729297c2a373d63a0d0ec;p=sbcl.git diff --git a/src/compiler/hppa/vm.lisp b/src/compiler/hppa/vm.lisp index 3a2477a..28f1db2 100644 --- a/src/compiler/hppa/vm.lisp +++ b/src/compiler/hppa/vm.lisp @@ -1,26 +1,35 @@ +;;;; miscellaneous VM definition noise for HPPA + +;;;; 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") -;;;; Define the registers +;;;; Registers (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *register-names* (make-array 32 :initial-element nil))) -;;; FIXME: These want to turn into macrolets. (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)))))) ;; Wired-zero (defreg zero 0) ;; This gets trashed by the C call convention. - (defreg nfp 1) + (defreg nfp 1) ;; and saved by lisp before calling C (defreg cfunc 2) ;; These are the callee saves, so these registers are stay live over ;; call-out. @@ -62,14 +71,19 @@ (defreg lip 31) (defregset non-descriptor-regs - nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc) + nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp) (defregset descriptor-regs - fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2) + a0 a1 a2 a3 a4 a5 fdefn lexenv ocfp lra l0 l1 l2) (defregset *register-arg-offsets* - a0 a1 a2 a3 a4 a5)) + a0 a1 a2 a3 a4 a5) + + (defregset reserve-descriptor-regs + fdefn lexenv) + (defregset reserve-non-descriptor-regs + cfunc)) (define-storage-base registers :finite :size 32) (define-storage-base float-registers :finite :size 64) @@ -81,29 +95,28 @@ ;;; ;;; Handy macro so we don't have to keep changing all the numbers whenever ;;; we insert a new storage class. -;;; +;;; FIXME-lav: move this into arch-generic-helpers.lisp and rip out from arches (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))) + (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 sb!vm::kludge-nondeterministic-catch-block-size 7) +(def!constant kludge-nondeterministic-catch-block-size 6) (!define-storage-classes - ;; Non-immediate contstants in the constant pool + ;; Non-immediate constants in the constant pool (constant constant) ;; ZERO and NULL are in registers. @@ -121,46 +134,55 @@ ;; 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). (any-reg registers :locations #.(append non-descriptor-regs descriptor-regs) - :constant-scs (zero immediate) + :reserve-locations #.(append reserve-non-descriptor-regs + reserve-descriptor-regs) + :constant-scs (constant zero immediate) :save-p t :alternate-scs (control-stack)) ;; Pointer descriptor objects. Must be seen by GC. (descriptor-reg registers :locations #.descriptor-regs + :reserve-locations #.reserve-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) + (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 + :reserve-locations #.reserve-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 :locations #.non-descriptor-regs + :reserve-locations #.reserve-non-descriptor-regs :constant-scs (immediate) :save-p t :alternate-scs (sap-stack)) @@ -168,11 +190,13 @@ ;; Non-Descriptor (signed or unsigned) numbers. (signed-reg registers :locations #.non-descriptor-regs + :reserve-locations #.reserve-non-descriptor-regs :constant-scs (zero immediate) :save-p t :alternate-scs (signed-stack)) (unsigned-reg registers :locations #.non-descriptor-regs + :reserve-locations #.reserve-non-descriptor-regs :constant-scs (zero immediate) :save-p t :alternate-scs (unsigned-stack)) @@ -217,137 +241,157 @@ :alternate-scs (complex-double-stack)) ;; A catch or unwind block. - (catch-block control-stack :element-size sb!vm::kludge-nondeterministic-catch-block-size)) + (catch-block control-stack :element-size kludge-nondeterministic-catch-block-size) + + + ;; floating point numbers temporarily stuck in integer registers for c-call + (single-int-carg-reg registers + :locations (26 25 24 23) + :alternate-scs () + :constant-scs ()) + (double-int-carg-reg registers + :locations (25 23) + :constant-scs () + :alternate-scs () +; :alignment 2 ;is this needed? +; :element-size 2 + )) ;;;; Make some random tns for important registers. +;;; how can we address reg L0 through L0-offset when it is not +;;; defined here ? do all registers have an -offset and this is +;;; redundant work ? +;;; +;;; FIXME-lav: move this into arch-generic-helpers (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))))) ;; These, we access by foo-TN only - + (defregtn zero any-reg) + (defregtn nargs any-reg) + ;; FIXME-lav: 20080820: not a fix, but fdefn and lexenv is used in assembly-rtns + (defregtn fdefn descriptor-reg) ; FIXME-lav, not used + (defregtn lexenv descriptor-reg) ; FIXME-lav, not used + + (defregtn nfp descriptor-reg) ; why not descriptor-reg ? + (defregtn ocfp any-reg) ; why not descriptor-reg ? + (defregtn null descriptor-reg) - (defregtn code descriptor-reg) - (defregtn alloc any-reg) + (defregtn bsp any-reg) - (defregtn csp any-reg) (defregtn cfp any-reg) + (defregtn csp any-reg) + (defregtn alloc any-reg) (defregtn nsp any-reg) - - ;; These alias regular locations, so we have to make sure we don't bypass - ;; the register allocator when using them. - (defregtn nargs any-reg) - (defregtn ocfp any-reg) + + (defregtn code descriptor-reg) (defregtn lip interior-reg)) ;; And some floating point values. (defparameter fp-single-zero-tn (make-random-tn :kind :normal - :sc (sc-or-lose 'single-reg) - :offset 0)) + :sc (sc-or-lose 'single-reg) + :offset 0)) (defparameter fp-double-zero-tn (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset 0)) + :sc (sc-or-lose 'double-reg) + :offset 0)) -;;; 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) +;;; If VALUE can be represented as an immediate constant, then return +;;; the appropriate SC number, otherwise return NIL. +(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) + 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)) (single-float (if (zerop value) - (sc-number-or-lose 'fp-single-zero) - nil)) + (sc-number-or-lose 'fp-single-zero) + nil)) (double-float (if (zerop value) - (sc-number-or-lose 'fp-double-zero) - nil)))) + (sc-number-or-lose 'fp-double-zero) + 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 ;;; The SC numbers for register and stack arguments/return values. ;;; -(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)) +(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 -(defconstant ocfp-save-offset 0) -(defconstant lra-save-offset 1) -(defconstant nfp-save-offset 2) +(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. ;;; -(defconstant register-arg-count 6) +(def!constant register-arg-count 6) ;;; Names to use for the argument registers. -;;; +;;; (defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal) -); 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*)) - -;;; SINGLE-VALUE-RETURN-BYTE-OFFSET -;;; -;;; This is used by the debugger. -;;; -(defconstant single-value-return-byte-offset 4) +(defparameter *register-arg-tns* + (mapcar (lambda (n) + (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 4) -;;; 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) +(defun 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 -;;; occure in the symbol table (for example, prepending an -;;; underscore). On the HPPA we just leave it alone. -(defun extern-alien-name (name) - (declare (type simple-base-string name)) - 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)