diff --git a/compiler/mips/char.lisp b/compiler/mips/char.lisp index a8b55df46f3c3acf9e7bad0dc5376355e2fde078..a48ebedbb3f1a170f4363584e1ee9b11fe790acb 100644 --- a/compiler/mips/char.lisp +++ b/compiler/mips/char.lisp @@ -7,64 +7,88 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/char.lisp,v 1.4 1990/03/22 23:53:02 ch Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/char.lisp,v 1.5 1990/04/23 16:44:49 wlott Exp $ ;;; ;;; This file contains the RT VM definition of character operations. ;;; ;;; Written by Rob MacLachlan ;;; Converted for the MIPS R2000 by Christopher Hoover. ;;; -(in-package 'c) +(in-package "C") + + +;;;; Moves and coercions: + +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-character) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (base-character-reg))) + (:generator 1 + (inst srl y x vm:type-bits))) +;;; +(define-move-vop move-to-base-character :move + (any-reg descriptor-reg) (base-character-reg)) + + +;;; Move an untagged char to a tagged representation. +;;; +(define-vop (move-from-base-character) + (:args (x :scs (base-character-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:generator 1 + (inst sll y x vm:type-bits) + (inst ori y y vm:base-character-type))) +;;; +(define-move-vop move-from-base-character :move + (base-character-reg) (any-reg descriptor-reg)) + +;;; Move untagged base-character values. +;;; (define-vop (base-character-move) (:args (x :target y :scs (base-character-reg) - :load nil)) + :load-if (not (location= x y)))) (:results (y :scs (base-character-reg) - :load nil)) - (:temporary (:scs (base-character-reg) :type base-character - :from :argument :to :result) - temp) + :load-if (not (location= x y)))) (:effects) (:affected) (:generator 0 - (sc-case x ((base-character-reg base-character-stack - immediate-base-character descriptor-reg - any-reg control-stack))) - (sc-case y ((base-character-reg base-character-stack - descriptor-reg any-reg control-stack))) - - (let* ((x-char (sc-is x base-character-reg base-character-stack - immediate-base-character)) - (y-char (sc-is y base-character-reg base-character-stack)) - (same-rep (if x-char y-char (not y-char))) - (src (if (sc-is x control-stack base-character-stack - immediate-base-character) - temp x)) - (dest (if (sc-is y control-stack base-character-stack) temp y))) - - (unless (and same-rep (location= x y)) - - (unless (eq x src) - (sc-case x - ((base-character-stack control-stack) - (load-stack-tn src x)) - (immediate-base-character - (loadi src (char-code (tn-value x)))))) - - (cond (same-rep - (move dest src)) - (x-char - (inst sll dest src vm:type-bits) - (inst ori dest dest vm:base-character-type)) - (t - (inst srl dest src vm:type-bits))) - - (unless (eq y dest) - (store-stack-tn y dest)))))) - -(primitive-type-vop base-character-move (:coerce-to-t :coerce-from-t :move) - base-character) + (move y x))) +;;; +(define-move-vop base-character-move :move + (base-character-reg) (base-character-reg)) + + +;;; Move untagged base-character arguments/return-values. +;;; +(define-vop (move-base-character-argument) + (:args (x :target y + :scs (base-character-reg)) + (fp :scs (descriptor-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 descriptor-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: (define-vop (char-code) (:args (ch :scs (base-character-reg) :target res)) @@ -84,8 +108,8 @@ (:generator 0 (inst srl res code 2))) -;;; Comparison of base-characters -- works for boxed and unboxed -;;; characters since we don't have bits, etc. + +;;; Comparison of base-characters. ;;; (define-vop (base-character-compare pointer-compare) (:args (x :scs (base-character-reg)) @@ -103,3 +127,4 @@ (define-vop (fast-char>/base-character base-character-compare) (:translate char>) (:variant :gt)) + diff --git a/compiler/mips/macros.lisp b/compiler/mips/macros.lisp index 6f91705a2f3394c10d756bdff31593fdf83eccc2..fd0c14940205a4f46a49a7f208de14309349b6ec 100644 --- a/compiler/mips/macros.lisp +++ b/compiler/mips/macros.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.28 1990/04/05 23:53:30 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.29 1990/04/23 16:45:03 wlott Exp $ ;;; ;;; This file contains various useful macros for generating MIPS code. ;;; @@ -159,17 +159,7 @@ (let ((offset (tn-offset stack))) (sc-case stack ((control-stack) - (loadw reg cont-tn offset)) - ((number-stack base-character-stack sap-stack) - (multiple-value-bind (cs-size ns-size) - (current-frame-size) - (declare (ignore cs-size)) - (unless (< (* offset vm:word-bytes) ns-size) - (cerror "Go ahead." - "~S is ~D words offset in the number stack, but ~ - the number stack is only ~D words long." - stack offset (/ ns-size 4))) - (loadw reg nsp-tn (- offset (/ ns-size vm:word-bytes))))))))) + (loadw reg fp-tn offset)))))) (defmacro store-stack-tn (stack reg) `(let ((stack ,stack) @@ -177,17 +167,7 @@ (let ((offset (tn-offset stack))) (sc-case stack ((control-stack) - (storew reg cont-tn offset)) - ((number-stack base-character-stack sap-stack) - (multiple-value-bind (cs-size ns-size) - (current-frame-size) - (declare (ignore cs-size)) - (unless (< (* offset vm:word-bytes) ns-size) - (cerror "Go ahead." - "~S is ~D words offset in the number stack, but ~ - the number stack is only ~D words long." - stack offset (/ ns-size 4))) - (storew reg nsp-tn (- offset (/ ns-size vm:word-bytes))))))))) + (storew reg fp-tn offset)))))) ;;;; Three Way Comparison @@ -424,7 +404,7 @@ ;; Partition the type codes. (collect ((low-tag-types) (header-word-types)) - (dolist (type (enumerate-type-codes types)) + (dolist (type types) (cond ((< type vm:lowtag-limit) (low-tag-types type)) (t diff --git a/compiler/mips/move.lisp b/compiler/mips/move.lisp index 6f8c00d839d4bdb7692ca2c8d3c8c9c991944362..806310a12bdd763d326108687ac6cb7290675ee5 100644 --- a/compiler/mips/move.lisp +++ b/compiler/mips/move.lisp @@ -7,92 +7,104 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.11 1990/04/11 16:49:05 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.12 1990/04/23 16:45:09 wlott Exp $ ;;; -;;; This file contains the RT VM definition of operand loading/saving and +;;; This file contains the MIPS VM definition of operand loading/saving and ;;; the Move VOP. ;;; -;;; Written by Rob MacLachlan +;;; Written by Rob MacLachlan. +;;; MIPS conversion by William Lott. ;;; (in-package "C") -;;; Load-Constant-TN -- Internal -;;; -;;; Load the Constant or immediate constant TN X into Y. Temp is a -;;; descriptor register temp or NIL, if none is available. Temp must be -;;; supplied if Y may be in memory. Node is for souce context. -;;; -(defun load-constant-tn (x y temp node) - (declare (type tn x y) (type (or tn null temp)) (type node node)) - (assemble node - (sc-case x - ((zero negative-immediate unsigned-immediate immediate - null random-immediate immediate-base-character immediate-sap) - (let ((val (tn-value x)) - (dest (sc-case y - ((any-reg descriptor-reg base-character-reg sap-reg) y) - ((control-stack number-stack sap-stack - base-character-stack) - temp)))) - (etypecase val - (integer - (loadi dest (fixnum val))) - (null - (move dest null-tn)) - (symbol - (load-symbol dest val)) - (string-char - (loadi dest (logior (ash (char-code val) type-bits) - base-character-type)))) - (unless (eq dest y) - (store-stack-tn y temp)))) - (constant - (sc-case y - ((any-reg descriptor-reg) - (loadw y code-tn (tn-offset x) other-pointer-type)) - (control-stack - (loadw temp code-tn (tn-offset x) other-pointer-type) - (store-stack-tn y temp))))))) + +(define-move-function (load-immediate 1) (vop x y) + ((null unsigned-immediate immediate zero negative-immediate + random-immediate immediate-base-character immediate-sap) + (any-reg descriptor-reg base-character-reg sap-reg)) + (let ((val (tn-value x))) + (etypecase val + (integer + (loadi y (fixnum val))) + (null + (move y null-tn)) + (symbol + (load-symbol y val)) + (character + (loadi y (logior (ash (char-code val) type-bits) + base-character-type)))))) + +(define-move-function (load-number 1) (vop x y) + ((null unsigned-immediate immediate zero negative-immediate random-immediate) + (signed-reg unsigned-reg)) + (loadi y (tn-value x))) + +(define-move-function (load-base-character 1) (vop x y) + ((immediate-base-character) (base-character-reg)) + (loadi y (char-code (tn-value x)))) + +(define-move-function (load-constant 5) (vop x y) + ((constant) (any-reg 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 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)) + (let ((nfp (current-nfp-tn vop))) + (loadw y nfp (tn-offset x)))) + +(define-move-function (load-single 5) (vop x y) + ((single-stack) (single-reg)) + (cerror "Do nothing." "Not yet." x y)) + +(define-move-function (load-double 7) (vop x y) + ((double-stack) (double-reg)) + (cerror "Do nothing." "Not yet." x y)) + +(define-move-function (store-stack 5) (vop x y) + ((any-reg descriptor-reg) (control-stack)) + (store-stack-tn y x)) + +(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)) + (let ((nfp (current-nfp-tn vop))) + (storew x nfp (tn-offset y)))) + +(define-move-function (store-single 5) (vop x y) + ((single-reg) (single-stack)) + (cerror "Do nothing." "Not yet." x y)) + +(define-move-function (store-double 7) (vop x y) + ((double-reg) (double-stack)) + (cerror "Do nothing." "Not yet." x y)) + ;;;; The Move VOP: ;;; -;;; The Move VOP is used for doing arbitrary moves when there is no -;;; type-specific move/coerce operation. - -;;; We need a register to do a memory-memory move. -;;; (define-vop (move) (:args (x :target y :scs (any-reg descriptor-reg) - :load nil)) + :load-if (not (location= x y)))) (:results (y :scs (any-reg descriptor-reg) - :load nil)) - (:temporary (:scs (descriptor-reg) - :from :argument :to :result) - temp) - (:node-var node) + :load-if (not (location= x y)))) (:effects) (:affected) (:generator 0 - (unless (location= x y) - (sc-case x - ((any-reg descriptor-reg) - (sc-case y - ((any-reg descriptor-reg) - (move y x)) - (control-stack - (store-stack-tn y x)))) - (control-stack - (sc-case y - ((any-reg descriptor-reg) - (load-stack-tn y x)) - (control-stack - (load-stack-tn temp x) - (store-stack-tn y temp)))) - (t - (unassemble (load-constant-tn x y temp node))))))) + (move y x))) +(define-move-vop move :move + (any-reg descriptor-reg) + (any-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 @@ -100,6 +112,27 @@ ;;; (primitive-type-vop move (:check) t) +;;; The Move-Argument VOP 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 descriptor-reg)) + (fp :scs (descriptor-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + ((any-reg descriptor-reg) + (move y x)) + (control-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-argument :move-argument + (any-reg descriptor-reg) + (any-reg descriptor-reg)) + + ;;;; ILLEGAL-MOVE @@ -115,73 +148,4 @@ (:generator 666 (error-call di:object-not-type-error x type))) - -;;;; Operand loading and saving: -;;; -;;; These are the VOPs used for loading or saving Load-TNs. They cannot -;;; allocate any temporaries since packing has already been done by the time -;;; that these VOPs are emitted. It can be assumed that the loaded (saved) TN -;;; is free before (after) the load (save) (so may be used as a temporary.) -;;; -(define-vop (load-operand) - (:args (x)) - (:results (y)) - (:node-var node) - (:generator 5 - (sc-case x - (control-stack - (sc-case y - ((any-reg descriptor-reg) - (load-stack-tn y x)) - (base-character-reg - (load-stack-tn y x) - (inst srl y y vm:type-bits)))) - (base-character-stack - (sc-case y - (base-character-reg - (load-stack-tn y x)))) - ((any-reg descriptor-reg) - (sc-case y - (base-character-reg - (inst srl y x vm:type-bits)))) - (t - (unassemble (load-constant-tn x y nil node)))))) - -(define-vop (store-operand) - (:args (x)) - (:results (y)) - (:generator 5 - (sc-case y - (control-stack - (sc-case x - ((any-reg descriptor-reg) - (store-stack-tn y x)) - (base-character-reg - (inst sll x x vm:type-bits) - (inst ori x x vm:base-character-type) - (store-stack-tn y x)))) - (base-character-stack - (sc-case x - (base-character-reg - (store-stack-tn y x)))) - ((any-reg descriptor-reg) - (sc-case x - (base-character-reg - (inst sll x x vm:type-bits) - (inst ori y x vm:base-character-type))))))) - - -;;;; Register saving and restoring VOPs. - -(define-vop (save-reg) - (:args (reg)) - (:results (stack)) - (:generator 5 - (store-stack-tn stack reg))) - -(define-vop (restore-reg) - (:args (stack)) - (:results (reg)) - (:generator 5 - (load-stack-tn reg stack))) diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp index aed17fe7485aa5d23ed36fd7d324cecbe2f3f545..0a7620df043f1b6b41b358af88966425de8005ed 100644 --- a/compiler/mips/nlx.lisp +++ b/compiler/mips/nlx.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.6 1990/03/20 00:09:42 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.7 1990/04/23 16:45:11 wlott Exp $ ;;; ;;; This file contains the definitions of VOPs used for non-local exit ;;; (throw, lexical exit, etc.) @@ -16,6 +16,15 @@ ;;; (in-package "C") +;;; MAKE-NLX-SP-TN -- Interface +;;; +;;; Make an environment-live stack TN for saving the SP for NLX entry. +;;; +(defun make-nlx-sp-tn (env) + (environment-live-tn (make-representation-tn (sc-number-or-lose 'any-reg)) + env)) + + ;;; Save and restore dynamic environment. ;;; @@ -33,25 +42,32 @@ ;;; use with the Save/Restore-Dynamic-Environment VOPs. ;;; (defun make-dynamic-state-tns () - (make-n-tns 4 *any-primitive-type*)) + (make-n-tns 5 *any-primitive-type*)) (define-vop (save-dynamic-state) (:results (catch :scs (descriptor-reg)) (special :scs (descriptor-reg)) - (number :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg)) (eval :scs (descriptor-reg))) + (:vop-var vop) (:generator 13 (load-symbol-value catch lisp::*current-catch-block*) (move special bsp-tn) - (move number nsp-tn) + (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 (descriptor-reg)) (special :scs (descriptor-reg)) - (number :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg)) (eval :scs (descriptor-reg))) (:temporary (:scs (descriptor-reg)) symbol value) + (:vop-var vop) (:generator 10 (let ((done (gen-label)) (skip (gen-label)) @@ -59,7 +75,10 @@ (store-symbol-value catch lisp::*current-catch-block*) (store-symbol-value eval lisp::*eval-stack-top*) - (move nsp-tn number) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move cur-nfp nfp))) + (move nsp-tn nsp) (inst beq special bsp-tn done) (nop) @@ -92,7 +111,7 @@ ;;;; Unwind block hackery: ;;; Compute the address of the catch block from its TN, then store into the -;;; block the current Cont, Env, Unwind-Protect, and the entry PC. +;;; block the current Fp, Env, Unwind-Protect, and the entry PC. ;;; (define-vop (make-unwind-block) (:args (tn)) @@ -101,10 +120,10 @@ (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :target block) result) (:generator 22 - (inst addiu result cont-tn (* (tn-offset tn) vm:word-bytes)) + (inst addiu result fp-tn (* (tn-offset tn) vm:word-bytes)) (load-symbol-value temp lisp::*current-unwind-protect-block*) (storew temp result vm:unwind-block-current-uwp-slot) - (storew cont-tn result vm:unwind-block-current-cont-slot) + (storew fp-tn result vm:unwind-block-current-cont-slot) (storew code-tn result vm:unwind-block-current-code-slot) (inst compute-lra-from-code temp code-tn entry-label) (storew temp result vm:catch-block-entry-pc-slot) @@ -116,16 +135,16 @@ ;;; (define-vop (make-catch-block) (:args (tn) - (tag :scs (any-reg descriptor-reg))) + (tag :scs (descriptor-reg))) (:info entry-label) (:results (block :scs (descriptor-reg))) (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :target block) result) (:generator 44 - (inst addiu result cont-tn (* (tn-offset tn) vm:word-bytes)) + (inst addiu result fp-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 cont-tn result vm:catch-block-current-cont-slot) + (storew fp-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) @@ -145,7 +164,7 @@ (:args (tn)) (:temporary (:scs (descriptor-reg)) new-uwp) (:generator 7 - (inst addiu new-uwp cont-tn (* (tn-offset tn) vm:word-bytes)) + (inst addiu new-uwp fp-tn (* (tn-offset tn) vm:word-bytes)) (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) @@ -232,12 +251,9 @@ (count :target num)) (:results (new-start) (new-count)) (:info label) - (:temporary (:scs (any-reg descriptor-reg) :type fixnum :from (:argument 0)) - dst) - (:temporary (:scs (any-reg descriptor-reg) :type fixnum :from (:argument 1)) - src) - (:temporary (:scs (any-reg descriptor-reg) :type fixnum :from (:argument 2)) - num) + (:temporary (:scs (any-reg) :type fixnum :from (:argument 0)) dst) + (:temporary (:scs (any-reg) :type fixnum :from (:argument 1)) src) + (:temporary (:scs (any-reg) :type fixnum :from (:argument 2)) num) (:temporary (:scs (descriptor-reg)) temp) (:save-p :force-to-stack) (:generator 30 diff --git a/compiler/mips/parms.lisp b/compiler/mips/parms.lisp index bc683cabd00763c2a446a8fe79127eebbaf4968b..35b5888a618e05a36706fd19bd398e50d183e2a4 100644 --- a/compiler/mips/parms.lisp +++ b/compiler/mips/parms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.43 1990/04/12 16:33:28 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.44 1990/04/23 16:45:16 wlott Exp $ ;;; ;;; This file contains some parameterizations of various VM ;;; attributes for the MIPS. This file is separate from other stuff so @@ -27,7 +27,7 @@ ;;; Maximum number of SCs allowed. ;;; -(defconstant sc-number-limit 26) +(defconstant sc-number-limit 32) ;;; The inclusive upper bound on a cost. We want to write cost frobbing ;;; code so that it is portable, but works on fixnums. This constant @@ -57,6 +57,10 @@ which has the MSB first (RT) or :little-endian which has the MSB last (VAX).") +;;; ### This should be somewhere else. +(defconstant native-byte-order :big-endian + "The byte order we are running under.") + ;;;; Description of the target address space. diff --git a/compiler/mips/sap.lisp b/compiler/mips/sap.lisp index ade0c6d283efde1e44d477a31d5fdd48fedc8ca2..a198baf6652bdc4b2212bd31863f4170e6bb4c68 100644 --- a/compiler/mips/sap.lisp +++ b/compiler/mips/sap.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.2 1990/03/22 23:50:34 ch Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.3 1990/04/23 16:45:19 wlott Exp $ ;;; ;;; This file contains the MIPS VM definition of SAP operations. ;;; @@ -15,58 +15,83 @@ ;;; (in-package "C") - -;;;; The SAP-MOVE vop. +;;;; Moves and coercions: + +;;; 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 an untagged SAP to a tagged representation. +;;; +(define-vop (move-from-sap) + (:args (x :scs (sap-reg) :target sap)) + (:temporary (:scs (sap-reg) :from (:argument 0)) sap) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (y :scs (descriptor-reg))) + (:generator 1 + (move sap x) + (pseudo-atomic (ndescr) + (inst addiu y alloc-tn vm:other-pointer-type) + (inst addiu alloc-tn alloc-tn (vm:pad-data-block vm:sap-size)) + (loadi ndescr (logior (ash vm:sap-size vm:type-bits) vm:sap-type)) + (storew y ndescr 0 vm:other-pointer-type) + (storew y sap vm:sap-pointer-slot vm:other-pointer-type)))) +;;; +(define-move-vop move-from-sap :move + (sap-reg) (descriptor-reg)) + +;;; Move untagged sap values. +;;; (define-vop (sap-move) - (:args (x :target y :scs (sap-reg) :load nil)) - (:results (y :scs (sap-reg) :load nil)) - (:temporary (:scs (sap-reg) :type system-area-pointer - :from :argument :to :result) sap) - (:temporary (:scs (descriptor-reg) :from :argument :to :result) temp) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (: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 - (sc-case x ((sap-reg sap-stack immediate-sap descriptor-reg control-stack))) - (sc-case y ((sap-reg sap-stack descriptor-reg control-stack))) - - (let* ((x-sap-p (sc-is x sap-reg sap-stack immediate-sap)) - (y-sap-p (sc-is y sap-reg sap-stack)) - (src (cond ((sc-is x sap-reg descriptor-reg) x) - (x-sap-p sap) - (t temp))) - (dst (cond ((sc-is y sap-reg descriptor-reg) y) - (y-sap-p sap) - (t temp)))) - - (sc-case x - ((control-stack sap-stack) - (load-stack-tn src x)) - ((descriptor-reg sap-reg)) - (immediate-sap - (loadi src (tn-value x)))) - (cond ((and x-sap-p (not y-sap-p)) - (pseudo-atomic (ndescr) - (inst addiu dst alloc-tn vm:other-pointer-type) - (inst addiu alloc-tn alloc-tn (pad-data-block vm:sap-size)) - (loadi ndescr (logior (ash vm:sap-size vm:type-bits) - vm:sap-type)) - (storew ndescr dst 0 vm:other-pointer-type) - (storew src dst vm:sap-pointer-slot vm:other-pointer-type))) - ((and y-sap-p (not x-sap-p)) - (loadw sap src vm:sap-pointer-slot vm:other-pointer-type)) - (t - (move dst src))) - (sc-case y - ((control-stack sap-stack) - (store-stack-tn y dst)) - ((sap-reg descriptor-reg)))))) - -(primitive-type-vop sap-move - (:coerce-to-t :coerce-from-t :move) - system-area-pointer) + (move y x))) +;;; +(define-move-vop sap-move :move + (sap-reg) (sap-reg)) + + +;;; Move untagged sap arguments/return-values. +;;; +(define-vop (move-sap-argument) + (:args (x :target y + :scs (sap-reg)) + (fp :scs (descriptor-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)) @@ -88,7 +113,7 @@ (:translate int-sap) (:policy :fast-safe) (:generator 0 - ;; ### Need to check to see if it is a bignum. + ;; ### Need to check to see if it is a bignum first. (inst srl sap int 2))) diff --git a/compiler/mips/static-fn.lisp b/compiler/mips/static-fn.lisp index b185eadf5d971e57410e751b263162c4989d3c5c..5807d205ee53ba2acf81e8c332a8433a44937134 100644 --- a/compiler/mips/static-fn.lisp +++ b/compiler/mips/static-fn.lisp @@ -7,7 +7,7 @@ ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.4 1990/04/03 12:43:43 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.5 1990/04/23 16:45:22 wlott Exp $ ;;; ;;; This file contains the VOPs and macro magic necessary to call static ;;; functions. @@ -23,7 +23,7 @@ (:policy :fast-safe) (:variant-vars symbol) (:node-var node) - (:temporary (:scs (descriptor-reg any-reg)) temp) + (:temporary (:scs (any-reg)) temp) (:temporary (:scs (descriptor-reg)) move-temp) (:temporary (:sc descriptor-reg :offset lra-offset) lra) (:temporary (:sc descriptor-reg :offset cname-offset) cname) @@ -31,8 +31,7 @@ (:temporary (:scs (descriptor-reg)) function) (:temporary (:scs (interior-reg) :type interior) lip) (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset args-offset) args) - (:temporary (:sc any-reg :offset oldcont-offset) old-cont)) + (:temporary (:sc any-reg :offset old-fp-offset) old-fp)) (eval-when (compile load eval) @@ -91,9 +90,8 @@ (loadi nargs (fixnum ,num-args)) (load-symbol cname symbol) (loadw lexenv cname vm:symbol-function-slot vm:other-pointer-type) - (move args cont-tn) - (move old-cont cont-tn) - (move cont-tn csp-tn) + (move old-fp fp-tn) + (move fp-tn csp-tn) (inst compute-lra-from-code lra code-tn lra-label) (loadw function lexenv vm:closure-function-slot vm:function-pointer-type) diff --git a/compiler/mips/vm.lisp b/compiler/mips/vm.lisp index 4a7d6c9f9dd9ccf99b37d4af394b94321ab36e4b..bb42657c032d744a3edb30c7dacfc507f46c5040 100644 --- a/compiler/mips/vm.lisp +++ b/compiler/mips/vm.lisp @@ -7,7 +7,7 @@ ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.21 1990/04/13 17:15:19 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.22 1990/04/23 16:45:25 wlott Exp $ ;;; ;;; This file contains the VM definition for the MIPS R2000 and the new ;;; object format. @@ -20,8 +20,9 @@ ;;;; SB and SC definition: (define-storage-base registers :finite :size 32) +(define-storage-base float-registers :finite :size 32) (define-storage-base control-stack :unbounded :size 8) -(define-storage-base number-stack :unbounded :size 8) +(define-storage-base non-descriptor-stack :unbounded :size 0) (define-storage-base constant :non-packed) (define-storage-base immediate-constant :non-packed) @@ -38,45 +39,11 @@ classes)))) (define-storage-classes - ;; Objects that can be stored in any register (immediate objects) - (any-reg registers - :locations (2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 28 31)) - - ;; Objects that must be seen by GC (pointer objects) - (descriptor-reg registers - :locations (8 9 10 11 12 13 14 15 16 17 18 19 28 31)) - - ;; Objects that must not be seen by GC (unboxed objects) - (non-descriptor-reg registers - :locations (2 3 4 5 6 7)) - - ;; Pointers to the interior of objects. - (interior-reg registers - :locations (1)) - - ;; Unboxed base-characters - (base-character-reg registers - :locations (2 3 4 5 6 7)) - - ;; Unboxed SAP's (arbitrary pointers into address space) - (sap-reg registers - :locations (2 3 4 5 6 7)) - - ;; Stack for descriptor objects (scanned by GC) - (control-stack control-stack) - - ;; Stack for non-descriptor objects (not scanned by GC) - (number-stack number-stack) - - ;; Unboxed base-character stack - (base-character-stack number-stack) - - ;; Unboxed SAP stack - (sap-stack number-stack) ;; Non-immediate contstants in the constant pool (constant constant) + ;; Immediate numeric constants. ;; ;; zero = (integer 0 0) @@ -98,203 +65,183 @@ (immediate immediate-constant) (unsigned-immediate immediate-constant) - ;; Immediate null/nil. + ;; Immediate SCs for things other than numbers. (null immediate-constant) - - ;; Immediate unboxed base-characters. (immediate-base-character immediate-constant) - - ;; Immediate unboxed SAP's. (immediate-sap immediate-constant) - ;; Objects that are easier to create using immediate loads than to fetch - ;; from the constant pool, but which aren't directly usable as immediate - ;; operands. These are only recognized by move VOPs. + ;; Anything else that can be computed faster than loaded that doesn't fit in + ;; any of the above immediate SCs. (random-immediate immediate-constant) - ;; A catch or unwind block. - (catch-block control-stack :element-size vm:catch-block-size)) - -;;;; Interfaces for stack sizes. + ;; **** The stacks. -(defun current-frame-size () - (values (* vm:word-bytes - (finite-sb-current-size (sb-or-lose 'control-stack))) - (* vm:word-bytes - (finite-sb-current-size (sb-or-lose 'number-stack))))) + ;; 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-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. - -;;;; Move costs. -;;; -;;; Move costs for operand loading and storing -;;; -#+nil ;; These move costs don't work. -(define-move-costs - ((immediate zero null random-immediate) - ;; load immediate or reg->reg move. - (1 any-reg descriptor-reg)) - - ((immediate-base-character) - ;; Load immediate. - (1 base-character-reg any-reg descriptor-reg)) - - ((immediate-sap) - ;; lui/ori pair. - (2 sap-reg)) - - ((any-reg) - ;; No conversion necessary for these. - (1 any-reg descriptor-reg) - ;; Must shift and addiu the type code. - (2 base-character-reg) - ;; No type conversion, but we have to write it on the stack. - (5 control-stack)) - - ((descriptor-reg) - ;; No conversion necessary for these. - (1 any-reg descriptor-reg) - ;; Must shift and addiu the type code. - (2 base-character-reg) - ;; Must indirect the src ptr. - (5 sap-reg) - ;; No type conversion, but we have to write it on the stack. - (5 control-stack)) - - ((base-character-reg) - ;; Just move. - (1 base-character-reg) - ;; Must add type info. - (2 any-reg descriptor-reg) - ;; Must store it. - (5 base-character-stack)) - - ((sap-reg) - ;; Just move - (1 sap-reg) - ;; Must allocate space for it. - (10 descriptor-reg) - ;; Must store it. - (5 sap-stack)) - - ((control-stack constant) - ;; Must indirect the stack/code pointer. - (5 any-reg descriptor-reg)) - - ((base-character-stack) - ;; Just indirect. - (5 base-character-reg)) - - ((sap-stack) - ;; Just indirect. - (5 sap-reg))) - -(define-move-costs - ((any-reg descriptor-reg non-descriptor-reg) - (1 any-reg descriptor-reg non-descriptor-reg) - (2 base-character-reg sap-reg) - (5 control-stack number-stack)) - - ((control-stack number-stack constant) - (5 any-reg descriptor-reg non-descriptor-reg) - (6 base-character-reg sap-reg)) - - ((immediate zero null random-immediate) - (1 any-reg descriptor-reg non-descriptor-reg)) - - ((immediate-base-character) - (1 base-character-reg) - (2 any-reg descriptor-reg non-descriptor-reg)) - - ((immediate-sap) - (1 sap-reg) - (2 any-reg descriptor-reg non-descriptor-reg)) - - ((base-character-reg) - (1 base-character-reg) - (2 any-reg descriptor-reg non-descriptor-reg) - (5 base-character-stack) - (6 control-stack number-stack)) - - ((sap-reg) - (1 sap-reg) - (2 any-reg descriptor-reg non-descriptor-reg) - (5 sap-stack) - (6 control-stack number-stack)) - - ((base-character-stack) - (5 base-character-reg)) - - ((sap-stack) - (5 sap-reg))) + + ;; **** 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 (2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 28 31) + :constant-scs (constant negative-immediate zero immediate unsigned-immediate + immediate-base-character random-immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Pointer descriptor objects. Must be seen by GC. + (descriptor-reg registers + :locations (8 9 10 11 12 13 14 15 16 17 18 19 28 31) + :constant-scs (constant negative-immediate zero immediate unsigned-immediate + immediate-base-character random-immediate null) + :save-p t + :alternate-scs (control-stack)) + + ;; Non-Descriptor characters + (base-character-reg registers + :locations (2 3 4 5 6 7) + :constant-scs (immediate-base-character) + :save-p t + :alternate-scs (base-character-stack)) + + ;; Non-Descriptor SAP's (arbitrary pointers into address space) + (sap-reg registers + :locations (2 3 4 5 6 7) + :constant-scs (immediate-sap) + :save-p t + :alternate-scs (sap-stack)) + + ;; Non-Descriptor (signed or unsigned) numbers. + (signed-reg registers + :locations (2 3 4 5 6 7) + :constant-scs (negative-immediate zero immediate unsigned-immediate + random-immediate) + :save-p t + :alternate-scs (signed-stack)) + (unsigned-reg registers + :locations (2 3 4 5 6 7) + :constant-scs (zero immediate unsigned-immediate random-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 (2 3 4 5 6 7)) + + ;; Pointers to the interior of objects. Used only as an temporary. + (interior-reg registers + :locations (1)) + + + ;; **** Things that can go in the floating point registers. + + ;; Non-Descriptor single-floats. + (single-reg float-registers + :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) + :constant-scs () + :save-p t + :alternate-scs (single-stack)) + + ;; Non-Descriptor double-floats. + (double-reg float-registers + :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (double-stack)) + + + + + ;; A catch or unwind block. + (catch-block control-stack :element-size vm:catch-block-size)) -;;; -;;; SCs which must saved on a function call. -(define-save-scs - (control-stack any-reg descriptor-reg) - (base-character-stack base-character-reg) - (sap-stack sap-reg)) ;;;; Primitive Type Definitions -(def-primitive-type t (descriptor-reg control-stack)) +;;; *Anything* +;;; +(def-primitive-type t (descriptor-reg)) (defvar *any-primitive-type* (primitive-type-or-lose 't)) -;;; -(def-primitive-type fixnum (any-reg control-stack)) +;;; Primitive integer types. +;;; +(def-primitive-type fixnum (any-reg)) +#| ### Rob needs to think about this more. +(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)) +(def-primitive-type negative-fixnum (any-reg signed-reg)) +(def-primitive-type negative-signed-byte-32 (signed-reg)) +(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg)) +(def-primitive-type unsigned-byte-32 (unsigned-reg)) +|# -(def-primitive-type base-character - (base-character-reg any-reg base-character-stack control-stack)) +;;; Other primitive immediate types. +(def-primitive-type base-character (base-character-reg any-reg)) +;;; Primitive pointer types. ;;; -(def-primitive-type function (descriptor-reg control-stack)) -(def-primitive-type list (descriptor-reg control-stack)) +(def-primitive-type function (descriptor-reg)) +(def-primitive-type list (descriptor-reg)) +(def-primitive-type structure (descriptor-reg)) -;;; -(def-primitive-type bignum (descriptor-reg control-stack)) -(def-primitive-type ratio (descriptor-reg control-stack)) -(def-primitive-type complex (descriptor-reg control-stack)) -(def-primitive-type single-float (descriptor-reg control-stack)) -(def-primitive-type double-float (descriptor-reg control-stack)) +;;; 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 single-float (single-reg descriptor-reg)) +(def-primitive-type double-float (double-reg descriptor-reg)) -;;; -(def-primitive-type simple-string (descriptor-reg control-stack) - :type simple-base-string) -(def-primitive-type simple-bit-vector (descriptor-reg control-stack)) -(def-primitive-type simple-vector (descriptor-reg control-stack)) -(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg control-stack) +;;; 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 control-stack) +(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 control-stack) +(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 control-stack) +(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 control-stack) +(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 control-stack) +(def-primitive-type simple-array-single-float (descriptor-reg) :type (simple-array single-float (*))) -(def-primitive-type simple-array-double-float (descriptor-reg control-stack) +(def-primitive-type simple-array-double-float (descriptor-reg) :type (simple-array double-float (*))) -(def-primitive-type system-area-pointer (sap-reg sap-stack)) +;;; Note: The complex array types are not inclueded, 'cause it is pointless to +;;; restrict VOPs to them. +;;; Other primitive other-pointer types. +;;; +(def-primitive-type system-area-pointer (sap-reg 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) -;;; -#| These are not needed 'cause its pointless to restrict VOPs to them. -(def-primitive complex-string (descriptor-reg control-stack)) -(def-primitive complex-bit-vector (descriptor-reg control-stack)) -(def-primitive complex-vector (descriptor-reg control-stack)) -|# ;;;; Primitive-type-of and friends. @@ -337,26 +284,46 @@ ;;; (defun primitive-type (type) (declare (type ctype type)) - (etypecase type - (numeric-type - (if (not (eq (numeric-type-complexp type) :real)) - (values *any-primitive-type* nil) - (case (numeric-type-class type) - (integer - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (if (and hi lo - (>= lo most-negative-fixnum) - (<= hi most-positive-fixnum)) - (values (primitive-type-or-lose 'fixnum) - (and (= lo most-negative-fixnum) - (= hi most-positive-fixnum))) - (values *any-primitive-type* nil)))) + (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 + (>= lo most-negative-fixnum) + (<= hi most-positive-fixnum)) + (values (primitive-type-or-lose 'fixnum) + (and (= lo most-negative-fixnum) + (= hi most-positive-fixnum)))) + ((or (and hi (< hi most-negative-fixnum)) + (and lo (> lo most-positive-fixnum))) + (part-of bignum)) + (t + (any)))) + (float + (let ((exact (and (null lo) (null hi)))) + (case (numeric-type-format type) + ((short-float single-float) + (values (primitive-type-or-lose 'single-float) exact)) + ((double-float long-float) + (values (primitive-type-or-lose 'double-float) exact)) + (t + (any))))) + (t + (any)))) + (:complex + (part-of complex)) (t - (values *any-primitive-type* nil))))) - (array-type + (any))))) + (array-type (if (array-type-complexp type) - (values *any-primitive-type* nil) + (any) (let* ((dims (array-type-dimensions type)) (etype (array-type-specialized-element-type type)) (type-spec (type-specifier etype)) @@ -364,38 +331,39 @@ :test #'equal)))) (if (and (consp dims) (null (rest dims)) ptype) (values (primitive-type-or-lose ptype) (eq (first dims) '*)) - (values *any-primitive-type* nil))))) - (union-type - (if (type= type (specifier-type 'list)) - (values (primitive-type-or-lose 'list) t) - (let ((types (union-type-types type))) - (multiple-value-bind (res exact) - (primitive-type (first types)) - (dolist (type (rest types)) - (multiple-value-bind (ptype ptype-exact) - (primitive-type type) - (unless ptype-exact (setq exact nil)) - (setq res (primitive-type-union res ptype)))) - (values res exact))))) - (member-type - (values (reduce #'primitive-type-union - (mapcar #'primitive-type-of - (member-type-members type))) - nil)) - (named-type - (case (named-type-name type) - ((t bignum ratio complex function system-area-pointer) - (values (primitive-type-or-lose (named-type-name type)) t)) - ((character base-character string-char) - (values (primitive-type-or-lose 'base-character) t)) - (standard-char - (values (primitive-type-or-lose 'base-character) nil)) - (cons - (values (primitive-type-or-lose 'list) nil)) - (t - (values *any-primitive-type* nil)))) - (ctype - (values *any-primitive-type* nil)))) + (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) + (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))))) ;;;; Magical Registers @@ -405,7 +373,7 @@ (defconstant lip-offset 1) (defconstant null-offset 20) (defconstant bsp-offset 21) - (defconstant cont-offset 22) + (defconstant fp-offset 22) (defconstant csp-offset 23) (defconstant flags-offset 24) (defconstant alloc-offset 25) @@ -442,10 +410,10 @@ ;;; ;;; Frame Pointer -(defparameter cont-tn +(defparameter fp-tn (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) - :offset cont-offset)) + :offset fp-offset)) ;;; ;;; Control stack pointer @@ -520,15 +488,13 @@ (if (vm:static-symbol-p value) (sc-number-or-lose 'random-immediate) nil)) - (fixnum + ((signed-byte 29) #+nil (or (signed-byte 32) (unsigned-byte 32)) (sc-number-or-lose 'random-immediate)) - ;; ### what here? - ;(sap - ; (sc-number-or-lose 'immediate-sap)) - (t - ;; - ;; ### hack around bug in (typep x 'string-char) - (if (and (characterp value) (string-char-p value)) + #+new-compiler + (system-area-pointer + (sc-number-or-lose 'immediate-sap)) + (character + (if (string-char-p value) (sc-number-or-lose 'immediate-base-character) nil)))) @@ -548,7 +514,7 @@ (defconstant cname-offset 14) (defconstant lexenv-offset 15) (defconstant args-offset 16) -(defconstant oldcont-offset 17) +(defconstant old-fp-offset 17) (defconstant lra-offset 18) ;;; A few additional registers distinct from all the linkage regs. These are @@ -561,9 +527,9 @@ (defconstant l0-offset 19) ;;; Offsets of special stack frame locations -(defconstant oldcont-save-offset 0) +(defconstant old-fp-save-offset 0) (defconstant lra-save-offset 1) -(defconstant lexenv-save-offset 2) +(defconstant nfp-save-offset 2) ); Eval-When (Compile Load Eval) @@ -578,6 +544,11 @@ :sc (sc-or-lose 'descriptor-reg) :offset args-offset)) +(defparameter old-fp-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset old-fp-offset)) + (defparameter lra-tn (make-random-tn :kind :normal :sc (sc-or-lose 'descriptor-reg) @@ -610,3 +581,22 @@ :sc (sc-or-lose 'descriptor-reg) :offset n)) register-arg-offsets)) + + + +;;; 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. +;;; +(defun location-print-name (tn) + (declare (type tn tn)) + (let ((sb (sb-name (sc-sb (tn-sc tn)))) + (offset (tn-offset tn))) + (ecase sb + (registers (mips:register-name (tn-offset tn))) + (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"))))