diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp index 327e4bdfc7243aded085bfcfc63f73bf15be397d..d60a31b15a405c507df57251b7de52673abd5525 100644 --- a/compiler/generic/vm-tran.lisp +++ b/compiler/generic/vm-tran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.12 1990/06/15 12:35:22 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.13 1990/06/16 15:35:44 wlott Exp $ ;;; ;;; This file contains impelemtentation-dependent transforms. ;;; @@ -25,7 +25,8 @@ (def-source-transform structurep (x) (once-only ((n-x x)) `(and (simple-vector-p ,n-x) - (eql (%primitive get-vector-subtype ,n-x) + (eql (truly-the (unsigned-byte 24) + (%primitive get-vector-subtype ,n-x)) system:%g-vector-structure-subtype)))) (def-source-transform compiled-function-p (x) @@ -51,7 +52,7 @@ (def-source-transform %more-arg-context (&rest foo) - `(%primitive more-arg-context ,@foo)) + `(truly-the (values t fixnum) (%primitive more-arg-context ,@foo))) ;;; (def-source-transform %verify-argument-count (&rest foo) `(%primitive verify-argument-count ,@foo)) diff --git a/compiler/generic/vm-type.lisp b/compiler/generic/vm-type.lisp index d1eb1267b70623614210fa4a15d3845beb14b458..17ee83a707bd707981dda3bdcbb14e2cf7acc9b8 100644 --- a/compiler/generic/vm-type.lisp +++ b/compiler/generic/vm-type.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.14 1990/05/15 01:20:59 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.15 1990/06/16 15:35:59 wlott Exp $ ;;; ;;; This file contains implementation-dependent parts of the type support ;;; code. This is stuff which deals with the mapping from types defined in @@ -44,7 +44,7 @@ ;;; ### Bootstrap hack: base characters don't exist in the old compiler, ;;; so leave characters alone. Also, make string-char look like base-char. (compiler-let ((lisp::*bootstrap-deftype* t)) - (remhash 'character *builtin-types*) + (setf (info type builtin 'character) nil) (deftype character () 'base-character) (deftype string-char () 'base-character)) diff --git a/compiler/mips/arith.lisp b/compiler/mips/arith.lisp index d43b43164a56ad50c7040c2d05486147dace20e9..b4b52a7a3a6bfb7d32d9ef3910938fbe7f41f636 100644 --- a/compiler/mips/arith.lisp +++ b/compiler/mips/arith.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.24 1990/06/12 02:29:53 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.25 1990/06/16 15:33:18 wlott Exp $ ;;; ;;; This file contains the VM definition arithmetic VOPs for the MIPS. ;;; @@ -68,10 +68,10 @@ ;;; Assume that any constant operand is the second arg... (define-vop (fast-fixnum-binop) - (:args (x :target r :scs (any-reg descriptor-reg)) - (y :target r :scs (any-reg descriptor-reg))) + (:args (x :target r :scs (any-reg)) + (y :target r :scs (any-reg))) (:arg-types tagged-num tagged-num) - (:results (r :scs (any-reg descriptor-reg))) + (:results (r :scs (any-reg))) (:result-types tagged-num) (:note "inline fixnum arithmetic") (:effects) @@ -108,9 +108,9 @@ "/FIXNUM=>FIXNUM")) fast-fixnum-binop) (:args (x :target r - :scs (any-reg descriptor-reg)) + :scs (any-reg)) (y :target r - :scs (any-reg descriptor-reg immediate zero + :scs (any-reg immediate zero ,(if unsigned 'unsigned-immediate 'negative-immediate)))) @@ -118,7 +118,7 @@ (:generator ,cost (inst ,op r x (sc-case y - ((any-reg descriptor-reg) y) + (any-reg y) (zero zero-tn) ((immediate ,(if unsigned 'unsigned-immediate 'negative-immediate)) @@ -176,23 +176,25 @@ ;;; know the output type is a fixnum. (define-vop (fast-+/fixnum fast-+/fixnum=>fixnum) - (:result-types *) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) (:note nil) (:generator 1 (inst add r x (sc-case y - ((any-reg descriptor-reg) y) + (any-reg y) (zero zero-tn) ((immediate negative-immediate) (fixnum (tn-value y))))))) (define-vop (fast--/fixnum fast--/fixnum=>fixnum) - (:result-types *) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) (:note nil) (:generator 1 (inst sub r x (sc-case y - ((any-reg descriptor-reg) y) + (any-reg y) (zero zero-tn) ((immediate negative-immediate) (fixnum (tn-value y))))))) @@ -204,7 +206,7 @@ (:note "inline ASH") (:args (number :scs (signed-reg unsigned-reg)) (amount :scs (signed-reg immediate negative-immediate))) - (:arg-types (:or signed-num unsigned-num) *) + (:arg-types (:or signed-num unsigned-num) signed-num) (:results (result :scs (signed-reg unsigned-reg))) (:result-types (:or signed-num unsigned-num)) (:translate ash) @@ -339,7 +341,7 @@ (y :target r :scs (signed-reg))) (:results (q :scs (signed-reg)) (r :scs (signed-reg))) - (:result-types * *) + (:result-types signed-num signed-num) (:generator 11 (let ((zero (generate-error-code division-by-zero-error x y))) (inst beq y zero-tn zero)) @@ -352,7 +354,7 @@ (:args (x :target r :scs (signed-reg)) (y :target r :scs (signed-reg))) (:results (r :scs (signed-reg))) - (:result-types *) + (:result-types signed-num) (:generator 10 (let ((zero (generate-error-code division-by-zero-error x y))) (inst beq y zero-tn zero)) @@ -377,6 +379,7 @@ (:arg-types tagged-num tagged-num) (:note "inline fixnum comparison")) +#+nil (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) (:arg-types tagged-num (:constant (signed-byte 14))) (:info target not-p y)) @@ -387,6 +390,7 @@ (:arg-types signed-num signed-num) (:note "inline (signed-byte 32) comparison")) +#+nil (define-vop (fast-conditional-c/signed fast-conditional/signed) (:arg-types tagged-num (:constant (signed-byte 16))) (:info target not-p y)) @@ -397,6 +401,7 @@ (:arg-types unsigned-num unsigned-num) (:note "inline (unsigned-byte 32) comparison")) +#+nil (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) (:arg-types tagged-num (:constant (unsigned-byte 15))) (:info target not-p y)) @@ -586,8 +591,7 @@ (:variant vm:bignum-digits-offset vm:other-pointer-type) (:translate bignum::%bignum-set) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg descriptor-reg - immediate unsigned-immediate)) + (index :scs (any-reg immediate unsigned-immediate)) (value :scs (unsigned-reg))) (:results (result :scs (unsigned-reg)))) diff --git a/compiler/mips/array.lisp b/compiler/mips/array.lisp index 2e0b838e74b8b1845aafc7f12fd8e9ec77e9aee7..af647def3cd028c106d5a866077541a3341074a8 100644 --- a/compiler/mips/array.lisp +++ b/compiler/mips/array.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.17 1990/06/04 05:21:36 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.18 1990/06/16 15:34:40 wlott Exp $ ;;; ;;; This file contains the MIPS definitions for array operations. ;;; @@ -99,7 +99,7 @@ ;;;; Accessors/Setters -(defmacro def-data-vector-frobs (type variant &optional (element-type t) sc) +(defmacro def-data-vector-frobs (type variant element-type &rest scs) `(progn (define-vop (,(intern (concatenate 'simple-string "DATA-VECTOR-REF/" @@ -109,10 +109,9 @@ "-REF"))) (:variant vm:vector-data-offset vm:other-pointer-type) (:translate data-vector-ref) - (:arg-types ,type *) - ,@(when sc - `((:results (value :scs (,sc))) - (:result-types ,element-type)))) + (:arg-types ,type positive-fixnum) + (:results (value :scs ,scs)) + (:result-types ,element-type)) (define-vop (,(intern (concatenate 'simple-string "DATA-VECTOR-SET/" (string type))) @@ -121,17 +120,16 @@ "-SET"))) (:variant vm:vector-data-offset vm:other-pointer-type) (:translate data-vector-set) - (:arg-types ,type * ,element-type) - ,@(when sc - `((:args (object :scs (descriptor-reg)) - (index :scs (any-reg descriptor-reg - immediate unsigned-immediate)) - (value :scs (,sc))) - (:results (result :scs (,sc)))))))) + (:arg-types ,type positive-fixnum ,element-type) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate unsigned-immediate)) + (value :scs ,scs)) + (:results (result :scs ,scs))))) (def-data-vector-frobs simple-string byte-index base-character base-character-reg) -(def-data-vector-frobs simple-vector word-index) +(def-data-vector-frobs simple-vector word-index + * descriptor-reg any-reg) (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index positive-fixnum unsigned-reg) diff --git a/compiler/mips/call.lisp b/compiler/mips/call.lisp index 012817ca3a486715593feecdf772259d00b16987..954e8b7c0a4239f221aa1d8543cd977187661c6b 100644 --- a/compiler/mips/call.lisp +++ b/compiler/mips/call.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.18 1990/06/10 20:22:33 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.19 1990/06/16 15:34:44 wlott Exp $ ;;; ;;; This file contains the VM definition of function call for the MIPS. ;;; @@ -28,8 +28,11 @@ (defun standard-argument-location (n) (declare (type unsigned-byte n)) (if (< n register-arg-count) - (make-wired-tn register-arg-scn (elt register-arg-offsets n)) - (make-wired-tn control-stack-arg-scn n))) + (make-wired-tn *any-primitive-type* + register-arg-scn + (elt register-arg-offsets n)) + (make-wired-tn *any-primitive-type* + control-stack-arg-scn n))) ;;; Make-Return-PC-Passing-Location -- Interface @@ -41,8 +44,8 @@ ;;; (defun make-return-pc-passing-location (standard) (if standard - (make-wired-tn register-arg-scn lra-offset) - (make-restricted-tn register-arg-scn))) + (make-wired-tn *any-primitive-type* register-arg-scn lra-offset) + (make-restricted-tn *any-primitive-type* register-arg-scn))) ;;; Make-Old-FP-Passing-Location -- Interface @@ -54,8 +57,8 @@ ;;; (defun make-old-fp-passing-location (standard) (if standard - (make-wired-tn register-arg-scn old-fp-offset) - (make-normal-tn *any-primitive-type*))) + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn old-fp-offset) + (make-normal-tn *fixnum-primitive-type*))) ;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface ;;; @@ -65,12 +68,14 @@ ;;; (defun make-old-fp-save-location (env) (environment-live-tn - (make-wired-tn (sc-number-or-lose 'control-stack) old-fp-save-offset) + (make-wired-tn *fixnum-primitive-type* + control-stack-arg-scn + old-fp-save-offset) env)) ;;; (defun make-return-pc-save-location (env) (environment-live-tn - (make-wired-tn (sc-number-or-lose 'control-stack) lra-save-offset) + (make-wired-tn *any-primitive-type* control-stack-arg-scn lra-save-offset) env)) ;;; Make-Argument-Count-Location -- Interface @@ -80,7 +85,7 @@ ;;; are using non-standard conventions. ;;; (defun make-argument-count-location () - (make-wired-tn register-arg-scn nargs-offset)) + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) ;;; MAKE-NFP-TN -- Interface @@ -90,7 +95,26 @@ ;;; (defun make-nfp-tn () (component-live-tn - (make-wired-tn (sc-number-or-lose 'any-reg) args-offset))) + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset))) + +;;; MAKE-STACK-POINTER-TN () +;;; +(defun make-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; MAKE-NUMBER-STACK-POINTER-TN () +;;; +(defun make-number-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; Make-Unknown-Values-Locations -- Interface +;;; +;;; Return a list of TNs that can be used to represent an unknown-values +;;; continuation within a function. +;;; +(defun make-unknown-values-locations () + (list (make-stack-pointer-tn) + (make-normal-tn *fixnum-primitive-type*))) ;;; Select-Component-Format -- Interface @@ -113,7 +137,7 @@ ;;; Used for setting up the Old-FP in local call. ;;; (define-vop (current-fp) - (:results (val :scs (any-reg descriptor-reg))) + (:results (val :scs (any-reg))) (:generator 1 (move val fp-tn))) @@ -121,7 +145,7 @@ ;;; works assuming there is no variable size stuff on the nstack. ;;; (define-vop (compute-old-nfp) - (:results (val :scs (any-reg descriptor-reg))) + (:results (val :scs (any-reg))) (:vop-var vop) (:generator 1 (let ((nfp (current-nfp-tn vop))) @@ -152,7 +176,7 @@ (move nfp-tn nsp-tn))))) (define-vop (allocate-frame) - (:results (res :scs (any-reg descriptor-reg)) + (:results (res :scs (any-reg)) (nfp :scs (any-reg))) (:info callee) (:generator 2 @@ -171,7 +195,7 @@ ;;; (define-vop (allocate-full-call-frame) (:info nargs) - (:results (res :scs (any-reg descriptor-reg))) + (:results (res :scs (any-reg))) (:generator 2 (when (> nargs register-arg-count) (move res csp-tn) @@ -220,12 +244,12 @@ regs-defaulted bltz temp default-value-4 ; jump to default code addu temp temp -1 - loadw move-temp args-tn 3 ; Move value to correct location. + loadw move-temp old-fp-tn 3 ; Move value to correct location. store-stack-tn val4-tn move-temp bltz temp default-value-5 addu temp temp -1 - loadw move-temp args-tn 4 + loadw move-temp old-fp-tn 4 store-stack-tn val5-tn move-temp ... @@ -289,11 +313,11 @@ default-value-5 (inst bltz temp default-lab) (inst addu temp temp (fixnum -1)) - (loadw move-temp args-tn i) + (loadw move-temp old-fp-tn i) (store-stack-tn tn move-temp))) (emit-label defaulting-done) - (move csp-tn args-tn) + (move csp-tn old-fp-tn) (assemble (*elsewhere*) (dolist (def (defaults)) @@ -358,8 +382,8 @@ default-value-5 ;;; (define-vop (unknown-values-receiver) (:results - (start :scs (descriptor-reg)) - (count :scs (descriptor-reg))) + (start :scs (any-reg)) + (count :scs (any-reg))) (:temporary (:sc descriptor-reg :offset old-fp-offset :from :eval :to (:result 0)) values-start) @@ -386,8 +410,8 @@ default-value-5 ;;; Nvals is the number of values received. ;;; (define-vop (call-local) - (:args (fp :scs (any-reg descriptor-reg)) - (nfp :scs (any-reg descriptor-reg)) + (:args (fp :scs (any-reg)) + (nfp :scs (any-reg)) (args :more t)) (:results (values :more t)) (:save-p t) @@ -422,8 +446,8 @@ default-value-5 ;;; glob and the number of values received. ;;; (define-vop (multiple-call-local unknown-values-receiver) - (:args (fp :scs (any-reg descriptor-reg)) - (nfp :scs (any-reg descriptor-reg)) + (:args (fp :scs (any-reg)) + (nfp :scs (any-reg)) (args :more t)) (:save-p t) (:move-args :local-call) @@ -456,8 +480,8 @@ default-value-5 ;;; just like argument passing in local call. ;;; (define-vop (known-call-local) - (:args (fp :scs (any-reg descriptor-reg)) - (nfp :scs (any-reg descriptor-reg)) + (:args (fp :scs (any-reg)) + (nfp :scs (any-reg)) (args :more t)) (:results (res :more t)) (:move-args :local-call) @@ -488,7 +512,7 @@ default-value-5 ;;; restore FP and CSP and jump to the Return-PC. ;;; (define-vop (known-return) - (:args (old-fp :scs (descriptor-reg)) + (:args (old-fp :scs (any-reg)) (return-pc :scs (descriptor-reg)) (vals :more t)) (:temporary (:scs (interior-reg) :type interior) lip) @@ -557,14 +581,14 @@ default-value-5 '(unknown-values-receiver))) (:args ,@(unless (eq return :tail) - '((new-fp :scs (descriptor-reg) :to :eval))) + '((new-fp :scs (any-reg) :to :eval))) ,(if named '(name :scs (descriptor-reg) :target name-pass) '(arg-fun :scs (descriptor-reg) :target lexenv :to :eval)) ,@(when (eq return :tail) - '((old-fp :scs (descriptor-reg) :target old-fp-pass) + '((old-fp :scs (any-reg) :target old-fp-pass) (return-pc :scs (descriptor-reg) :target return-pc-pass))) ,@(unless variable '((args :more t)))) @@ -717,9 +741,9 @@ default-value-5 (expand `(define-vop (tail-call-variable) (:args - (args :scs (descriptor-reg) :to (:result 0)) + (args :scs (any-reg) :to (:result 0)) (function-arg :scs (descriptor-reg) :target lexenv) - (old-fp-arg :scs (descriptor-reg) :target old-fp) + (old-fp-arg :scs (any-reg) :target old-fp) (return-pc-arg :scs (descriptor-reg) :target return-pc)) (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 0)) lexenv) @@ -883,10 +907,10 @@ default-value-5 register-arg-names))) `(define-vop (return-multiple) (:args - (old-fp :scs (descriptor-reg) :to (:eval 1)) + (old-fp :scs (any-reg) :to (:eval 1)) (return-pc :scs (descriptor-reg) :to (:eval 1)) - (start :scs (descriptor-reg any-reg) :target src) - (nvals :scs (descriptor-reg any-reg) :target nargs)) + (start :scs (any-reg) :target src) + (nvals :scs (any-reg) :target nargs)) (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nargs) ,@(mapcar #'(lambda (name offset) `(:temporary (:sc descriptor-reg :offset ,offset @@ -1076,13 +1100,13 @@ default-value-5 ;;; Turn more arg (context, count) into a list. ;;; (define-vop (listify-rest-args) - (:args (context-arg :target context :scs (any-reg descriptor-reg)) - (count-arg :target count :scs (any-reg descriptor-reg))) + (:args (context-arg :target context :scs (descriptor-reg)) + (count-arg :target count :scs (any-reg))) (:temporary (:scs (any-reg) :from (:argument 0)) context) (:temporary (:scs (any-reg) :from (:argument 1)) count) (:temporary (:scs (descriptor-reg) :from :eval) temp) (:temporary (:scs (non-descriptor-reg) :from :eval) ndescr dst) - (:results (result :scs (any-reg descriptor-reg))) + (:results (result :scs (descriptor-reg))) (:translate %listify-rest-args) (:policy :safe) (:generator 20 @@ -1137,11 +1161,11 @@ default-value-5 ;;; (define-vop (more-arg-context) (:args - (supplied :scs (any-reg descriptor-reg))) + (supplied :scs (any-reg))) (:info fixed) (:results (context :scs (descriptor-reg)) - (count :scs (any-reg descriptor-reg))) + (count :scs (any-reg))) (:generator 5 (inst addu count supplied (fixnum (- fixed))) (inst subu context csp-tn count))) @@ -1151,7 +1175,7 @@ default-value-5 ;;; (define-vop (verify-argument-count) (:args - (nargs :scs (any-reg descriptor-reg))) + (nargs :scs (any-reg))) (:temporary (:scs (any-reg) :type fixnum) temp) (:info count) (:generator 3 diff --git a/compiler/mips/debug.lisp b/compiler/mips/debug.lisp index f50b89cf6804db522314b31759baf62cf634ce19..1011fbaa82e98757749f65dde7ee8651ef156a0d 100644 --- a/compiler/mips/debug.lisp +++ b/compiler/mips/debug.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/debug.lisp,v 1.1 1990/06/03 19:11:05 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/debug.lisp,v 1.2 1990/06/16 15:34:52 wlott Exp $ ;;; ;;; Compiler support for the new whizzy debugger. ;;; @@ -51,17 +51,18 @@ (:translate stack-ref) (:policy :fast-safe) (:results (result :scs (descriptor-reg))) + (:result-types *) (:variant :long nil)) (define-vop (write-control-stack sap-set) (:translate %set-stack-ref) (:policy :fast-safe) (:args (object :scs (sap-reg) :target sap) - (offset :scs (descriptor-reg any-reg negative-immediate - zero immediate)) + (offset :scs (any-reg negative-immediate zero immediate)) (value :scs (descriptor-reg) :target result)) (:arg-types system-area-pointer positive-fixnum *) (:results (result :scs (descriptor-reg))) + (:result-types *) (:variant :long)) (define-vop (code-from-mumble) diff --git a/compiler/mips/memory.lisp b/compiler/mips/memory.lisp index 2a8447194fe45d1f95c4fb2bb1bf179eb70c6cfc..de14d49a7ac2d6e0ffc9b217e8977c28244c65b1 100644 --- a/compiler/mips/memory.lisp +++ b/compiler/mips/memory.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.7 1990/04/24 02:56:11 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.8 1990/06/16 15:35:14 wlott Exp $ ;;; ;;; This file contains the MIPS definitions of some general purpose memory ;;; reference VOPs inherited by basic memory reference operations. @@ -108,7 +108,7 @@ (defmacro define-indexer (name write-p op shift) `(define-vop (,name) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg descriptor-reg immediate negative-immediate)) + (index :scs (any-reg zero immediate negative-immediate)) ,@(when write-p '((value :scs (any-reg descriptor-reg) :target result)))) (:temporary (:scs (interior-reg) :type interior) lip) @@ -120,9 +120,11 @@ (:policy :fast-safe) (:generator 5 (sc-case index - ((immediate negative-immediate) + ((immediate zero negative-immediate) (inst ,op value object - (- (+ (ash (tn-value index) (- word-shift ,shift)) + (- (+ (if (sc-is index zero) + 0 + (ash (tn-value index) (- word-shift ,shift))) (ash offset word-shift)) lowtag)) ,(if write-p diff --git a/compiler/mips/move.lisp b/compiler/mips/move.lisp index 34b3abf993da2a5f7e895669ee27ca1460e9ae92..bd8cfa40b71e74899137d8cf9b2b9c5ba4ad58ca 100644 --- a/compiler/mips/move.lisp +++ b/compiler/mips/move.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.16 1990/06/04 05:23:37 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.17 1990/06/16 15:35:17 wlott Exp $ ;;; ;;; This file contains the MIPS VM definition of operand loading/saving and ;;; the Move VOP. @@ -118,7 +118,7 @@ (define-vop (move-argument) (:args (x :target y :scs (any-reg descriptor-reg)) - (fp :scs (descriptor-reg) + (fp :scs (any-reg) :load-if (not (sc-is y any-reg descriptor-reg)))) (:results (y)) (:generator 0 @@ -265,7 +265,7 @@ (define-vop (move-signed/unsigned-argument) (:args (x :target y :scs (signed-reg unsigned-reg)) - (fp :scs (any-reg descriptor-reg) + (fp :scs (any-reg) :load-if (not (sc-is y sap-reg)))) (:results (y)) (:generator 0 diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp index 68b8624b7aeb4a4cbb0f3355e2b62f4d5c79b61a..131e1f5786fc854f5419a7ed6ed7872f8116b328 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.9 1990/06/03 19:02:10 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.10 1990/06/16 15:35:21 wlott Exp $ ;;; ;;; This file contains the definitions of VOPs used for non-local exit ;;; (throw, lexical exit, etc.) @@ -21,8 +21,9 @@ ;;; 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)) + (environment-live-tn + (make-representation-tn *fixnum-primitive-type* immediate-arg-scn) + env)) @@ -116,7 +117,7 @@ (define-vop (make-unwind-block) (:args (tn)) (:info entry-label) - (:results (block :scs (descriptor-reg))) + (:results (block :scs (any-reg))) (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :target block) result) (:generator 22 @@ -137,7 +138,7 @@ (:args (tn) (tag :scs (descriptor-reg))) (:info entry-label) - (:results (block :scs (descriptor-reg))) + (:results (block :scs (any-reg))) (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :target block) result) (:generator 44 @@ -169,7 +170,7 @@ (define-vop (unlink-catch-block) - (:temporary (:scs (descriptor-reg)) block) + (:temporary (:scs (any-reg)) block) (:policy :fast-safe) (:translate %catch-breakup) (:generator 17 @@ -178,7 +179,7 @@ (store-symbol-value block lisp::*current-catch-block*))) (define-vop (unlink-unwind-protect) - (:temporary (:scs (descriptor-reg)) block) + (:temporary (:scs (any-reg)) block) (:policy :fast-safe) (:translate %unwind-protect-breakup) (:generator 17 diff --git a/compiler/mips/sap.lisp b/compiler/mips/sap.lisp index 233a0ca4038cb504239ebe01b271619634f4d772..593b1cef64aad236a91f009cabd4d667e1a919f6 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.11 1990/05/14 07:15:58 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.12 1990/06/16 15:35:25 wlott Exp $ ;;; ;;; This file contains the MIPS VM definition of SAP operations. ;;; @@ -150,10 +150,9 @@ (:policy :fast-safe) (:variant-vars size signed) (:args (object :scs (sap-reg) :target sap) - (offset :scs (descriptor-reg any-reg negative-immediate zero - immediate unsigned-immediate))) + (offset :scs (any-reg negative-immediate zero immediate))) (:arg-types system-area-pointer positive-fixnum) - (:results (result :scs (signed-reg unsigned-reg))) + (:results (result)) (:temporary (:scs (sap-reg) :from (:argument 0)) sap) (:temporary (:scs (non-descriptor-reg)) temp) (:generator 5 @@ -195,11 +194,11 @@ (:policy :fast-safe) (:variant-vars size) (:args (object :scs (sap-reg) :target sap) - (offset :scs (descriptor-reg any-reg negative-immediate - zero immediate)) + (offset :scs (any-reg negative-immediate zero immediate)) (value :scs (signed-reg unsigned-reg) :target result)) - (:arg-types system-area-pointer positive-fixnum *) + (:arg-types system-area-pointer positive-fixnum (:or signed-num unsigned-num)) (:results (result :scs (signed-reg unsigned-reg))) + (:result-types (:or signed-num unsigned-num)) (:temporary (:scs (sap-reg) :from (:argument 0)) sap) (:temporary (:scs (non-descriptor-reg)) temp) @@ -238,56 +237,73 @@ (define-vop (sap-system-ref sap-ref) (:translate sap-ref-sap) (:results (result :scs (sap-reg))) + (:result-types system-area-pointer) (:variant :long nil)) (define-vop (sap-system-set sap-set) (:translate %set-sap-ref-sap) (:args (object :scs (sap-reg) :target sap) - (offset :scs (descriptor-reg any-reg negative-immediate - zero immediate)) + (offset :scs (any-reg negative-immediate zero immediate)) (value :scs (sap-reg) :target result)) (:arg-types system-area-pointer positive-fixnum system-area-pointer) (:results (result :scs (sap-reg))) + (:result-types system-area-pointer) (:variant :long)) (define-vop (32bit-system-ref sap-ref) (:translate sap-ref-32) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) (:variant :long nil)) (define-vop (signed-32bit-system-ref sap-ref) (:translate signed-sap-ref-32) + (:results (result :scs (signed-reg))) + (:result-types signed-num) (:variant :long t)) (define-vop (32bit-system-set sap-set) (:translate %set-sap-ref-32) + (:arg-types system-area-pointer positive-fixnum + (:or unsigned-num signed-num)) (:variant :long)) (define-vop (16bit-system-ref sap-ref) (:translate sap-ref-16) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) (:variant :short nil)) (define-vop (signed-16bit-system-ref sap-ref) (:translate signed-sap-ref-16) + (:results (result :scs (signed-reg))) + (:result-types tagged-num) (:variant :short t)) (define-vop (16bit-system-set sap-set) (:translate %set-sap-ref-16) + (:arg-types system-area-pointer positive-fixnum tagged-num) (:variant :short)) (define-vop (8bit-system-ref sap-ref) (:translate sap-ref-8) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) (:variant :byte nil)) (define-vop (signed-8bit-system-ref sap-ref) (:translate signed-sap-ref-8) + (:results (result :scs (signed-reg))) + (:result-types tagged-num) (:variant :byte t)) (define-vop (8bit-system-set sap-set) (:translate %set-sap-ref-8) + (:arg-types system-area-pointer positive-fixnum tagged-num) (:variant :byte)) diff --git a/compiler/mips/type-vops.lisp b/compiler/mips/type-vops.lisp index 6f67199d959e94a14a924635eafbbcfc3c43d486..fd58e7bc28e1547c042454e9aff0860da8079392 100644 --- a/compiler/mips/type-vops.lisp +++ b/compiler/mips/type-vops.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.17 1990/06/04 06:13:43 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.18 1990/06/16 15:35:31 wlott Exp $ ;;; ;;; This file contains the VM definition of type testing and checking VOPs ;;; for the RT. @@ -474,3 +474,25 @@ (emit-label not-coercable-label) (error-call object-not-coercable-to-function-error object))))) + +(define-vop (fast-safe-coerce-to-function) + (:args (object :scs (descriptor-reg) + :target result)) + (:results (result :scs (descriptor-reg))) + (:temporary (:type random :scs (non-descriptor-reg)) nd-temp) + (:temporary (:scs (descriptor-reg)) saved-object) + (:generator 0 + (let ((not-function-label (gen-label)) + (done-label (gen-label))) + (test-simple-type object nd-temp not-function-label t + vm:function-pointer-type) + (move result object) + (emit-label done-label) + + (assemble (*elsewhere*) + (emit-label not-function-label) + (move saved-object object) + (loadw result object vm:symbol-function-slot vm:other-pointer-type) + (test-simple-type result nd-temp done-label nil + vm:function-pointer-type) + (error-call undefined-symbol-error saved-object))))) diff --git a/compiler/mips/values.lisp b/compiler/mips/values.lisp index 02fc1684b793de0cc8800f5cfa82d9f84eebed47..c874e5a9a36185e9031bdeaf1632f1f9dee809f1 100644 --- a/compiler/mips/values.lisp +++ b/compiler/mips/values.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.8 1990/06/04 05:23:53 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.9 1990/06/16 15:35:37 wlott Exp $ ;;; ;;; This file contains the implementation of unknown-values VOPs. ;;; @@ -36,8 +36,8 @@ (:args (vals :more t)) (:results - (start :scs (descriptor-reg)) - (count :scs (any-reg descriptor-reg))) + (start :scs (any-reg)) + (count :scs (any-reg))) (:info nvals) (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) @@ -68,8 +68,8 @@ (:args (arg :scs (descriptor-reg) :target list)) (:arg-types list) (:policy :fast-safe) - (:results (start :scs (any-reg descriptor-reg)) - (count :scs (descriptor-reg))) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (non-descriptor-reg) :type random) ndescr) diff --git a/compiler/mips/vm.lisp b/compiler/mips/vm.lisp index 7f5bb39a2c2dabdf81c779a47e6de80b2d96b4fe..11e2047c3e0c2a09ce480173abd6fe8fd2ff5b53 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.29 1990/06/03 18:56:47 ch Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.30 1990/06/16 15:36:02 wlott Exp $ ;;; ;;; This file contains the VM definition for the MIPS R2000 and the new ;;; object format. @@ -202,6 +202,8 @@ (def-primitive-type signed-byte-32 (signed-reg descriptor-reg) :type (signed-byte 32)) +(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum)) + (def-primitive-type-alias tagged-num (:or positive-fixnum fixnum)) (def-primitive-type-alias unsigned-num (:or unsigned-byte-32 unsigned-byte-31 @@ -418,7 +420,7 @@ (defconstant a5-offset 13) (defconstant cname-offset 14) (defconstant lexenv-offset 15) - (defconstant args-offset 16) + (defconstant nfp-offset 16) (defconstant old-fp-offset 17) (defconstant lra-offset 18) (defconstant l0-offset 19) @@ -558,6 +560,7 @@ ;;; The SC numbers for register and stack arguments/return values. ;;; (defconstant register-arg-scn (sc-number-or-lose 'descriptor-reg)) +(defconstant immediate-arg-scn (sc-number-or-lose 'any-reg)) (defconstant control-stack-arg-scn (sc-number-or-lose 'control-stack)) (eval-when (compile load eval) @@ -575,11 +578,6 @@ :sc (sc-or-lose 'any-reg) :offset nargs-offset)) -(defparameter args-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset args-offset)) - (defparameter old-fp-tn (make-random-tn :kind :normal :sc (sc-or-lose 'descriptor-reg)