From 96ae38aefc56943e2f43d0fc76e736152d8a45d0 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Wed, 6 Jun 1990 14:20:03 +0000 Subject: [PATCH] Merged in changes from the MIPS branch, mainly the primitive-type-aliases stuff. load-function => move-function Add meta-compile-time primitive-type info so that we can do more consistency checking. Put back primitive-type args to TN constructors. Changed load-scs vector to hold a list of all SCs that we can load into, ot T if the SC is directly allowed. Added consistency checking to compare the operand primitive-type restrictions with the SC restrictions. --- compiler/vmdef.lisp | 322 +++++++++++++++++++++++++++++++------------- 1 file changed, 231 insertions(+), 91 deletions(-) diff --git a/compiler/vmdef.lisp b/compiler/vmdef.lisp index 77901f211..59a390970 100644 --- a/compiler/vmdef.lisp +++ b/compiler/vmdef.lisp @@ -179,7 +179,7 @@ :Constant-SCs (SC*) A list of the names of all the constant SCs that can be loaded into this - SC by a load function." + SC by a move function." (check-type name symbol) (check-type number sc-number) @@ -278,11 +278,12 @@ (do-sc-pairs (from-sc to-sc ',scs) (unless (eq from-sc to-sc) (let ((num (sc-number from-sc))) - (setf (svref (sc-load-functions to-sc) num) ',name) + (setf (svref (sc-move-functions to-sc) num) ',name) (setf (svref (sc-load-costs to-sc) num) ',cost))))) (defun ,name ,lambda-list - (assemble (vop-node ,(first lambda-list)) ,@body)))) + (assemble (vop-node ,(first lambda-list)) + ,@body)))) (defconstant sc-vop-slots '((:move . sc-move-vops) @@ -354,13 +355,42 @@ ;;; (defvar *primitive-type-names* (make-hash-table :test #'eq)) +;;; Establishes a convenient handle on primitive type unions, or whatever. +;;; These names can only be used as the :arg-types or :result-types for VOPs +;;; and can map to anything else that can be used as :arg-types or +;;; :result-types (e.g. :or, :constant). +;;; +(defvar *primitive-type-aliases* (make-hash-table :test #'eq)) + +;;; Meta-compile time translation from names to primitive types. +;;; +(eval-when (compile load eval) + (defvar *meta-primitive-type-names* (make-hash-table :test #'eq))) + + +;;; PRIMITIVE-TYPE-OR-LOSE, META-PRIMITIVE-TYPE-OR-LOSE -- Interface +;;; +;;; Return the primitive type corresponding to the specified name, or die +;;; trying. +;;; +(defun primitive-type-or-lose (name) + (the primitive-type + (or (gethash name *primitive-type-names*) + (error "~S is not a defined primitive type." name)))) +;;; +(defun meta-primitive-type-or-lose (name) + (the primitive-type + (or (gethash name *meta-primitive-type-names*) + (error "~S is not a defined primitive type." name)))) + + ;;; The primitive type T is somewhat magical, in that it is the only primitive ;;; type that overlaps with other primitive types. An object of primitive-type ;;; T is in the canonical descriptor (boxed or pointer) representation. ;;; ;;; We stick the T primitive-type in a variable so that people who have to ;;; special-case it can get at it conveniently. This is done by the machine -;;; specific VM definition, since the Def-Primitive-Type for T must specify the +;;; specific VM definition, since the DEF-PRIMITIVE-TYPE for T must specify the ;;; SCs that boxed objects can be allocated in. ;;; (proclaim '(special *any-primitive-type*)) @@ -376,38 +406,46 @@ ;;; (defmacro def-primitive-type (name scs &key (type name)) "Def-Primitive-Type Name (SC*) {Key Value}* - Define a primitive type Name. Each SC specifies a Storage Class that values - of this type may be allocated in. The following keyword options are defined: - + Define a primitive type Name. Each SC specifies a Storage Class that values + of this type may be allocated in. The following keyword options are + defined: + :Type The type descriptor for the Lisp type that is equivalent to this type (defaults to Name.)" (check-type name symbol) (check-type scs list) - (once-only ((n-old `(gethash ',name *primitive-type-names*)) - (n-scs `(mapcar #'meta-sc-number-or-lose ',scs)) - (n-type `(specifier-type ',type))) + (let ((scns (mapcar #'meta-sc-number-or-lose scs)) + (get-type `(specifier-type ',type))) `(progn - (cond (,n-old - (setf (primitive-type-scs ,n-old) ,n-scs) - (setf (primitive-type-type ,n-old) ,n-type)) - (t - (setf (gethash ',name *primitive-type-names*) - (make-primitive-type :name ',name - :scs ,n-scs - :type ,n-type)))) - ',name))) + (eval-when (compile load eval) + (setf (gethash ',name *meta-primitive-type-names*) + (make-primitive-type :name ',name :scs ',scns + :type ,get-type))) + ,(once-only ((n-old `(gethash ',name *primitive-type-names*)) + (n-type get-type)) + `(progn + (cond (,n-old + (setf (primitive-type-scs ,n-old) ',scns) + (setf (primitive-type-type ,n-old) ,n-type)) + (t + (setf (gethash ',name *primitive-type-names*) + (make-primitive-type :name ',name :scs ',scns + :type ,n-type)))) + ',name))))) -;;; Primitive-Type-Or-Lose -- Interface -;;; -;;; Return the primitive type corresponding to the spesicifed name, or die -;;; trying. +;;; Def-Primitive-Type-Alias -- Public ;;; -(defun primitive-type-or-lose (name) - (the primitive-type - (or (gethash name *primitive-type-names*) - (error "~S is not a defined primitive type." name)))) +;;; Just record the translation. +;;; +(defmacro def-primitive-type-alias (name result) + "DEF-PRIMITIVE-TYPE-ALIAS Name Result + Define name to be an alias for Result in VOP operand type restrictions." + `(eval-when (compile load eval) + (setf (gethash ',name *primitive-type-aliases*) + ',result) + ',name)) (eval-when (compile load eval) @@ -441,6 +479,26 @@ types) nil))) + +;;; SC-ALLOWED-BY-PRIMITIVE-TYPE -- Interface +;;; +;;; Return true if SC is either one of Ptype's SC's, or one of those SC's +;;; alternate or constant SCs. If Meta-P is true, use meta-compile time info. +;;; +(defun sc-allowed-by-primitive-type (sc ptype &optional meta-p) + (declare (type sc sc) (type primitive-type ptype)) + (let ((scn (sc-number sc))) + (dolist (allowed (primitive-type-scs ptype) nil) + (when (eql allowed scn) + (return t)) + (let ((allowed-sc (svref (if meta-p + *meta-sc-numbers* + *sc-numbers*) + allowed))) + (when (or (member sc (sc-alternate-scs allowed-sc)) + (member sc (sc-constant-scs allowed-sc))) + (return t)))))) + ;;;; VOP definition structures: ;;; @@ -596,9 +654,8 @@ ;; NIL if no load-TN was allocated. (load-tn (gensym) :type symbol) ;; - ;; If true, automatic operand loading is inhibited and the operand name is - ;; always bound to the original TN. - (load t :type boolean) + ;; An expression that tests whether to do automatic operand loading. + (load t) ;; ;; In a wired or restricted temporary this is the SC the TN is to be packed ;; in. Null otherwise. @@ -851,8 +908,8 @@ (offset (operand-parse-offset temp))) (assert sc) (if offset - `(make-wired-tn ,(meta-sc-number-or-lose sc) ,offset) - `(make-restricted-tn ,(meta-sc-number-or-lose sc))))) + `(make-wired-tn nil ,(meta-sc-number-or-lose sc) ,offset) + `(make-restricted-tn nil ,(meta-sc-number-or-lose sc))))) ;;; Allocate-Temporaries -- Internal @@ -983,14 +1040,14 @@ ;;;; Generator functions: -;;; FIND-LOAD-FUNCTIONS -- Internal +;;; FIND-MOVE-FUNCTIONS -- Internal ;;; ;;; Return an alist that translates from lists of SCs we can load OP from to -;;; the load function used for loading those SCs. We quietly ignore +;;; the move function used for loading those SCs. We quietly ignore ;;; restrictions to :non-packed (constant) SCs, since we don't load into those ;;; SCs. ;;; -(defun find-load-functions (op load-p) +(defun find-move-functions (op load-p) (collect ((funs)) (dolist (sc-name (operand-parse-scs op)) (let* ((sc (meta-sc-or-lose sc-name)) @@ -1003,12 +1060,12 @@ (dolist (alt load-scs) (let* ((altn (sc-number alt)) (name (if load-p - (svref (sc-load-functions sc) altn) - (svref (sc-load-functions alt) scn))) + (svref (sc-move-functions sc) altn) + (svref (sc-move-functions alt) scn))) (found (or (assoc alt (funs) :test #'member) (rassoc name (funs))))) (unless name - (error "No load function defined to ~:[save~;load~] SC ~S~ + (error "No move function defined to ~:[save~;load~] SC ~S~ ~:[to~;from~] from SC ~S." load-p sc-name load-p (sc-name alt))) @@ -1029,17 +1086,17 @@ (funs))) -;;; CALL-LOAD-FUNCTION -- Internal +;;; CALL-MOVE-FUNCTION -- Internal ;;; ;;; Return a form to load/save the specified operand when it has a load TN. ;;; For any given SC that we can load from, there must be a unique load -;;; function. If all SCs we can load from have the same load function, then we +;;; function. If all SCs we can load from have the same move function, then we ;;; just call that when there is a load TN. If there are multiple possible -;;; load functions, then we dispatch off of the operand TN's type to see which -;;; load function to use. +;;; move functions, then we dispatch off of the operand TN's type to see which +;;; move function to use. ;;; -(defun call-load-function (parse op load-p) - (let ((funs (find-load-functions op load-p)) +(defun call-move-function (parse op load-p) + (let ((funs (find-move-functions op load-p)) (load-tn (operand-parse-load-tn op))) (if funs (let* ((tn `(tn-ref-tn ,(operand-parse-temp op))) @@ -1063,7 +1120,7 @@ `(when (eq ,load-tn ,(operand-parse-name op)) ,form))) `(when ,load-tn - (error "Load TN allocated, but no load function?~@ + (error "Load TN allocated, but no move function?~@ VM definition inconsistent, recompile and try again."))))) @@ -1118,8 +1175,8 @@ (cond ((and (operand-parse-load op) (operand-parse-scs op)) (binds `(,name ,(decide-to-load parse op))) (if (eq (operand-parse-kind op) :argument) - (loads (call-load-function parse op t)) - (saves (call-load-function parse op nil)))) + (loads (call-move-function parse op t)) + (saves (call-move-function parse op nil)))) (t (binds `(,name (tn-ref-tn ,temp))))))) (:temporary @@ -1150,7 +1207,7 @@ (declare (ignore ,@(vop-parse-ignores parse))) ,@(loads) (assemble (vop-node ,n-vop) - ,@(vop-parse-body parse)) + ,@(vop-parse-body parse)) ,@(saves)))))) @@ -1376,7 +1433,7 @@ ;;; ;;; Given an operand, returns two values: ;;; 1] A SC-vector of the cost for the operand being in that SC, including both -;;; the costs for load functions and coercion VOPs. +;;; the costs for move functions and coercion VOPs. ;;; 2] A SC-vector holding the SC that we load into, for any SC that we can ;;; directly load from. ;;; @@ -1392,7 +1449,7 @@ (let* ((load-sc (meta-sc-or-lose sc-name)) (load-scn (sc-number load-sc))) (setf (svref costs load-scn) 0) - (setf (svref load-scs load-scn) load-scn) + (setf (svref load-scs load-scn) t) (dolist (op-sc (append (when load-p (sc-constant-scs load-sc)) (sc-alternate-scs load-sc))) @@ -1401,7 +1458,7 @@ (aref (sc-load-costs load-sc) op-scn) (aref (sc-load-costs op-sc) load-scn)))) (unless load - (error "No load function defined to move ~:[from~;to~] SC ~ + (error "No move function defined to move ~:[from~;to~] SC ~ ~S~%~:[to~;from~] alternate or constant SC ~S." load-p sc-name load-p (sc-name op-sc))) @@ -1409,7 +1466,9 @@ (when (or (not op-cost) (< load op-cost)) (setf (svref costs op-scn) load))) - (setf (svref load-scs op-scn) load-scn))) + (let ((op-load (svref load-scs op-scn))) + (unless (eq op-load t) + (pushnew load-scn (svref load-scs op-scn)))))) (dotimes (i sc-number-limit) (unless (svref costs i) @@ -1424,14 +1483,11 @@ (values costs load-scs))) -(defconstant no-costs +(defparameter no-costs (make-array sc-number-limit :initial-element 0)) -(defconstant no-loads - (let ((res (make-array sc-number-limit))) - (dotimes (i sc-number-limit) - (setf (svref res i) i)) - res)) +(defparameter no-loads + (make-array sc-number-limit :initial-element 't)) ;;; COMPUTE-LOADING-COSTS-IF-ANY -- Internal @@ -1496,27 +1552,97 @@ ;;; (defun parse-operand-types (specs args-p) (declare (list specs)) - (mapcar #'(lambda (spec) - (cond ((eq spec '*) spec) - ((symbolp spec) - `(:or ,spec)) - ((atom spec) - (error "Bad thing to be a operand type: ~S." spec)) - (t - (case (first spec) - (:or - (unless (every #'symbolp (rest spec)) - (error "Bad PRIMITIVE-TYPE name in ~S." spec)) - spec) - (:constant - (unless args-p - (error "Can't :CONSTANT for a result.")) - (unless (= (length spec) 2) - (error "Bad :CONSTANT argument type spec: ~S." spec)) - spec) - (t - (error "Bad thing to be a operand type: ~S." spec)))))) - specs)) + (labels ((parse-operand-type (spec) + (cond ((eq spec '*) spec) + ((symbolp spec) + (let ((alias (gethash spec *primitive-type-aliases*))) + (if alias + (parse-operand-type alias) + `(:or ,spec)))) + ((atom spec) + (error "Bad thing to be a operand type: ~S." spec)) + (t + (case (first spec) + (:or + (collect ((results)) + (results :or) + (dolist (item (cdr spec)) + (unless (symbolp item) + (error "Bad PRIMITIVE-TYPE name in ~S: ~S" + spec item)) + (let ((alias + (gethash item *primitive-type-aliases*))) + (if alias + (let ((alias (parse-operand-type alias))) + (unless (eq (car alias) :or) + (error "Can't include primitive-type ~ + alias ~S in a :OR restriction: ~S." + item spec)) + (dolist (x (cdr alias)) + (results x))) + (results item)))) + (remove-duplicates (results) + :test #'eq + :start 1))) + (:constant + (unless args-p + (error "Can't :CONSTANT for a result.")) + (unless (= (length spec) 2) + (error "Bad :CONSTANT argument type spec: ~S." spec)) + spec) + (t + (error "Bad thing to be a operand type: ~S." spec))))))) + (mapcar #'parse-operand-type specs))) + + +;;; CHECK-OPERAND-TYPE-SCS -- Internal +;;; +;;; Check the consistency of Op's Sc restrictions with the specified +;;; primitive-type restriction. :CONSTANT operands have already been filtered +;;; out, so only :OR and * restrictions are left. +;;; +;;; We check that every representation allowed by the type can be directly +;;; loaded into some SC in the restriction, and that the type allows every SC +;;; in the restriction. With *, we require that T satisfy the first test, and +;;; omit the second. +;;; +(defun check-operand-type-scs (parse op type load-p) + (declare (type vop-parse parse) (type operand-parse op)) + (let ((ptypes (if (eq type '*) (list 't) (rest type))) + (scs (operand-parse-scs op))) + (when scs + (multiple-value-bind (costs load-scs) + (compute-loading-costs op load-p) + (declare (ignore costs)) + (dolist (ptype ptypes) + (unless (dolist (rep (primitive-type-scs + (meta-primitive-type-or-lose ptype)) + nil) + (when (svref load-scs rep) (return t))) + (error "In the ~A ~:[result~;argument~] to VOP ~S,~@ + none of the SCs allowed by the operand type ~S can ~ + directly be loaded~@ + into any of the restriction's SCs:~% ~S~:[~;~@ + [* type operand must allow T's SCs.]~]" + (operand-parse-name op) load-p (vop-parse-name parse) + ptype + scs (eq type '*))))) + + (dolist (sc scs) + (unless (or (eq type '*) + (dolist (ptype ptypes nil) + (when (sc-allowed-by-primitive-type + (meta-sc-or-lose sc) + (meta-primitive-type-or-lose ptype) + t) + (return t)))) + (warn "~:[Result~;Argument~] ~A to VOP ~S~@ + has SC restriction ~S which is ~ + not allowed by the operand type:~% ~S" + load-p (operand-parse-name op) (vop-parse-name parse) + sc type))))) + + (undefined-value)) ;;; Check-Operand-Types -- Internal @@ -1524,12 +1650,10 @@ ;;; If the operand types are specified, then check the number specified ;;; against the number of defined operands. ;;; -;;; [### This would be a good place to check if the operand type is consistent -;;; with the SC restriction.] -;;; -(defun check-operand-types (ops more-op types what) - (declare (list ops) (type (or list (member :unspecified)) types) - (type (or operand-parse null) more-op) (string what)) +(defun check-operand-types (parse ops more-op types load-p) + (declare (type vop-parse parse) (list ops) + (type (or list (member :unspecified)) types) + (type (or operand-parse null) more-op)) (unless (eq types :unspecified) (let ((num (+ (length ops) (if more-op 1 0)))) (unless (= (count-if-not #'(lambda (x) @@ -1537,11 +1661,22 @@ (eq (car x) :constant))) types) num) - (error "Expected ~D ~A type~P: ~S." num what types num))) + (error "Expected ~D ~:[result~;argument~] type~P: ~S." + num load-p types num))) + (when more-op (let ((mtype (car (last types)))) (when (and (consp mtype) (eq (first mtype) :constant)) - (error "Can't use :CONSTANT on VOP more args."))))) + (error "Can't use :CONSTANT on VOP more args.")))) + + (when (vop-parse-translate parse) + (mapc #'(lambda (x y) + (check-operand-type-scs parse x y load-p)) + (if more-op (butlast ops) ops) + (remove-if #'(lambda (x) + (and (consp x) + (eq (car x) ':constant))) + (if more-op (butlast types) types))))) (undefined-value)) @@ -1563,16 +1698,18 @@ (list (vop-parse-more-results parse))) (vop-parse-temps parse))) - (check-operand-types (vop-parse-args parse) + (check-operand-types parse + (vop-parse-args parse) (vop-parse-more-args parse) (vop-parse-arg-types parse) - "argument") + t) - (check-operand-types (vop-parse-results parse) + (check-operand-types parse + (vop-parse-results parse) (vop-parse-more-results parse) (vop-parse-result-types parse) - "result") + nil) (undefined-value)) @@ -1966,6 +2103,9 @@ (setf (template-type ,n-res) (specifier-type (template-type-specifier ,n-res))) ,@(set-up-function-translation parse n-res)) + #-new-compiler + (eval-when (compile) + (clc::clc-mumble "vop ~S compiled.~%" ',name)) ',name))) -- GitLab