/[cmucl]/src/compiler/meta-vmdef.lisp
ViewVC logotype

Diff of /src/compiler/meta-vmdef.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by emarsden, Fri Apr 11 15:28:11 2003 UTC revision 1.9.48.2 by rtoy, Thu Feb 11 02:19:58 2010 UTC
# Line 20  Line 20 
20  ;;;  ;;;
21  (in-package :c)  (in-package :c)
22    
23    (intl:textdomain "cmucl")
24    
25  (export '(define-storage-base define-storage-class define-move-function  (export '(define-storage-base define-storage-class define-move-function
26            define-move-function define-move-vop            define-move-function define-move-vop
27            meta-primitive-type-or-lose            meta-primitive-type-or-lose
# Line 36  Line 38 
38  ;;; missing slots at load time.  ;;; missing slots at load time.
39  ;;;  ;;;
40  (defmacro define-storage-base (name kind &key size)  (defmacro define-storage-base (name kind &key size)
41    "Define-Storage-Base Name Kind {Key Value}*    _N"Define-Storage-Base Name Kind {Key Value}*
42    Define a storage base having the specified Name.  Kind may be :Finite,    Define a storage base having the specified Name.  Kind may be :Finite,
43    :Unbounded or :Non-Packed.  The following keywords are legal:    :Unbounded or :Non-Packed.  The following keywords are legal:
44    
# Line 48  Line 50 
50    (ecase kind    (ecase kind
51      (:non-packed      (:non-packed
52       (when size       (when size
53         (error "Size specification meaningless in a ~S SB." kind)))         (error _"Size specification meaningless in a ~S SB." kind)))
54      ((:finite :unbounded)      ((:finite :unbounded)
55       (unless size (error "Size not specified in a ~S SB." kind))       (unless size (error _"Size not specified in a ~S SB." kind))
56       (check-type size unsigned-byte)))       (check-type size unsigned-byte)))
57    
58    (let ((res (if (eq kind :non-packed)    (let ((res (if (eq kind :non-packed)
# Line 86  Line 88 
88  (defmacro define-storage-class (name number sb-name &key (element-size '1)  (defmacro define-storage-class (name number sb-name &key (element-size '1)
89                                       (alignment '1) locations reserve-locations                                       (alignment '1) locations reserve-locations
90                                       save-p alternate-scs constant-scs)                                       save-p alternate-scs constant-scs)
91    "Define-Storage-Class Name Number Storage-Base {Key Value}*    _N"Define-Storage-Class Name Number Storage-Base {Key Value}*
92    Define a storage class Name that uses the named Storage-Base.  Number is a    Define a storage class Name that uses the named Storage-Base.  Number is a
93    small, non-negative integer that is used as an alias.  The following    small, non-negative integer that is used as an alias.  The following
94    keywords are defined:    keywords are defined:
# Line 131  Line 133 
133    (check-type alternate-scs list)    (check-type alternate-scs list)
134    (check-type constant-scs list)    (check-type constant-scs list)
135    (unless (= (logcount alignment) 1)    (unless (= (logcount alignment) 1)
136      (error "Alignment is not a power of two: ~S" alignment))      (error _"Alignment is not a power of two: ~S" alignment))
137    
138    (let ((sb (meta-sb-or-lose sb-name)))    (let ((sb (meta-sb-or-lose sb-name)))
139      (if (eq (sb-kind sb) :finite)      (if (eq (sb-kind sb) :finite)
# Line 141  Line 143 
143            (dolist (el locations)            (dolist (el locations)
144              (check-type el unsigned-byte)              (check-type el unsigned-byte)
145              (unless (<= 1 (+ el element-size) size)              (unless (<= 1 (+ el element-size) size)
146                (error "SC element ~D out of bounds for ~S." el sb))))                (error _"SC element ~D out of bounds for ~S." el sb))))
147          (when locations          (when locations
148            (error ":Locations is meaningless in a ~S SB." (sb-kind sb))))            (error _":Locations is meaningless in a ~S SB." (sb-kind sb))))
149    
150      (unless (subsetp reserve-locations locations)      (unless (subsetp reserve-locations locations)
151        (error "Reserve-Locations not a subset of Locations."))        (error _"Reserve-Locations not a subset of Locations."))
152    
153      (when (and (or alternate-scs constant-scs)      (when (and (or alternate-scs constant-scs)
154                 (eq (sb-kind sb) :non-packed))                 (eq (sb-kind sb) :non-packed))
155        (error "Meaningless to specify alternate or constant SCs in a ~S SB."        (error _"Meaningless to specify alternate or constant SCs in a ~S SB."
156               (sb-kind sb))))               (sb-kind sb))))
157    
158    (let ((nstack-p    (let ((nstack-p
# Line 181  Line 183 
183    
184         (let ((old (svref (backend-sc-numbers *target-backend*) ',number)))         (let ((old (svref (backend-sc-numbers *target-backend*) ',number)))
185           (when (and old (not (eq (sc-name old) ',name)))           (when (and old (not (eq (sc-name old) ',name)))
186             (warn "Redefining SC number ~D from ~S to ~S." ',number             (warn _"Redefining SC number ~D from ~S to ~S." ',number
187                   (sc-name old) ',name)))                   (sc-name old) ',name)))
188    
189         (setf (svref (backend-sc-numbers *target-backend*) ',number)         (setf (svref (backend-sc-numbers *target-backend*) ',number)
# Line 213  Line 215 
215  ;;; DEFINE-MOVE-FUNCTION  --  Public  ;;; DEFINE-MOVE-FUNCTION  --  Public
216  ;;;  ;;;
217  (defmacro define-move-function ((name cost) lambda-list scs &body body)  (defmacro define-move-function ((name cost) lambda-list scs &body body)
218    "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form*    _N"Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form*
219    Define the function Name and note it as the function used for moving operands    Define the function Name and note it as the function used for moving operands
220    from the From-SCs to the To-SCs.  Cost is the cost of this move operation.    from the From-SCs to the To-SCs.  Cost is the cost of this move operation.
221    The function is called with three arguments: the VOP (for context), and the    The function is called with three arguments: the VOP (for context), and the
# Line 221  Line 223 
223    All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of    All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of
224    DEFINE-VOP."    DEFINE-VOP."
225    (when (or (oddp (length scs)) (null scs))    (when (or (oddp (length scs)) (null scs))
226      (error "Malformed SCs spec: ~S." scs))      (error _"Malformed SCs spec: ~S." scs))
227    (check-type cost index)    (check-type cost index)
228    `(progn    `(progn
229       (eval-when (compile load eval)       (eval-when (compile load eval)
# Line 245  Line 247 
247  ;;; (including implicit loading).  ;;; (including implicit loading).
248  ;;;  ;;;
249  (defmacro define-move-vop (name kind &rest scs)  (defmacro define-move-vop (name kind &rest scs)
250    "Define-Move-VOP Name {:Move | :Move-Argument} {(From-SC*) (To-SC*)}*    _N"Define-Move-VOP Name {:Move | :Move-Argument} {(From-SC*) (To-SC*)}*
251    Make Name be the VOP used to move values in the specified From-SCs to the    Make Name be the VOP used to move values in the specified From-SCs to the
252    representation of the To-SCs.  If kind is :Move-Argument, then the VOP takes    representation of the To-SCs.  If kind is :Move-Argument, then the VOP takes
253    an extra argument, which is the frame pointer of the frame to move into."    an extra argument, which is the frame pointer of the frame to move into."
254    (when (or (oddp (length scs)) (null scs))    (when (or (oddp (length scs)) (null scs))
255      (error "Malformed SCs spec: ~S." scs))      (error _"Malformed SCs spec: ~S." scs))
256    (let ((accessor (or (cdr (assoc kind sc-vop-slots))    (let ((accessor (or (cdr (assoc kind sc-vop-slots))
257                        (error "Unknown kind ~S." kind))))                        (error _"Unknown kind ~S." kind))))
258      `(progn      `(progn
259         ,@(when (eq kind :move)         ,@(when (eq kind :move)
260             `((eval-when (compile load eval)             `((eval-when (compile load eval)
# Line 282  Line 284 
284  (defun meta-primitive-type-or-lose (name)  (defun meta-primitive-type-or-lose (name)
285    (the primitive-type    (the primitive-type
286         (or (gethash name (backend-meta-primitive-type-names *target-backend*))         (or (gethash name (backend-meta-primitive-type-names *target-backend*))
287             (error "~S is not a defined primitive type." name))))             (error _"~S is not a defined primitive type." name))))
288    
289  ;;; Def-Primitive-Type  --  Public  ;;; Def-Primitive-Type  --  Public
290  ;;;  ;;;
# Line 292  Line 294 
294  ;;; break the running compiler.  ;;; break the running compiler.
295  ;;;  ;;;
296  (defmacro def-primitive-type (name scs &key (type name))  (defmacro def-primitive-type (name scs &key (type name))
297    "Def-Primitive-Type Name (SC*) {Key Value}*    _N"Def-Primitive-Type Name (SC*) {Key Value}*
298     Define a primitive type Name.  Each SC specifies a Storage Class that values     Define a primitive type Name.  Each SC specifies a Storage Class that values
299     of this type may be allocated in.  The following keyword options are     of this type may be allocated in.  The following keyword options are
300     defined:     defined:
# Line 331  Line 333 
333  ;;; Just record the translation.  ;;; Just record the translation.
334  ;;;  ;;;
335  (defmacro def-primitive-type-alias (name result)  (defmacro def-primitive-type-alias (name result)
336    "DEF-PRIMITIVE-TYPE-ALIAS Name Result    _N"DEF-PRIMITIVE-TYPE-ALIAS Name Result
337    Define name to be an alias for Result in VOP operand type restrictions."    Define name to be an alias for Result in VOP operand type restrictions."
338    `(eval-when (compile load eval)    `(eval-when (compile load eval)
339       (setf (gethash ',name (backend-primitive-type-aliases *target-backend*))       (setf (gethash ',name (backend-primitive-type-aliases *target-backend*))
# Line 344  Line 346 
346  ;;; Primitive-Type-Vop  --  Public  ;;; Primitive-Type-Vop  --  Public
347  ;;;  ;;;
348  (defmacro primitive-type-vop (vop kinds &rest types)  (defmacro primitive-type-vop (vop kinds &rest types)
349    "Primitive-Type-VOP Vop (Kind*) Type*    _N"Primitive-Type-VOP Vop (Kind*) Type*
350    Annotate all the specified primitive Types with the named VOP under each of    Annotate all the specified primitive Types with the named VOP under each of
351    the specified kinds:    the specified kinds:
352    
# Line 361  Line 363 
363                      #'(lambda (kind)                      #'(lambda (kind)
364                          (let ((slot (or (cdr (assoc kind                          (let ((slot (or (cdr (assoc kind
365                                                      primitive-type-slot-alist))                                                      primitive-type-slot-alist))
366                                          (error "Unknown kind: ~S." kind))))                                          (error _"Unknown kind: ~S." kind))))
367                            `(setf (,slot ,n-type) ,n-vop)))                            `(setf (,slot ,n-type) ,n-vop)))
368                      kinds)))                      kinds)))
369            types)            types)
# Line 577  Line 579 
579                       :key #'operand-parse-name)))                       :key #'operand-parse-name)))
580      (if found      (if found
581          (unless (member (operand-parse-kind found) kinds)          (unless (member (operand-parse-kind found) kinds)
582            (error "Operand ~S isn't one of these kinds: ~S." name kinds))            (error _"Operand ~S isn't one of these kinds: ~S." name kinds))
583          (when error-p          (when error-p
584            (error "~S is not an operand to ~S." name (vop-parse-name parse))))            (error _"~S is not an operand to ~S." name (vop-parse-name parse))))
585      found))      found))
586    
587    
# Line 592  Line 594 
594  (defun vop-parse-or-lose (name &optional (backend *target-backend*))  (defun vop-parse-or-lose (name &optional (backend *target-backend*))
595    (the vop-parse    (the vop-parse
596         (or (gethash name (backend-parsed-vops backend))         (or (gethash name (backend-parsed-vops backend))
597             (error "~S is not the name of a defined VOP." name))))             (error _"~S is not the name of a defined VOP." name))))
598    
599    
600  ;;; Access-Operands  --  Internal  ;;; Access-Operands  --  Internal
# Line 634  Line 636 
636  (defun vop-spec-arg (spec type &optional (n 1) (last t))  (defun vop-spec-arg (spec type &optional (n 1) (last t))
637    (let ((len (length spec)))    (let ((len (length spec)))
638      (when (<= len n)      (when (<= len n)
639        (error "~:R argument missing: ~S." n spec))        (error _"~:R argument missing: ~S." n spec))
640      (when (and last (> len (1+ n)))      (when (and last (> len (1+ n)))
641        (error "Extra junk at end of ~S." spec))        (error _"Extra junk at end of ~S." spec))
642      (let ((thing (elt spec n)))      (let ((thing (elt spec n)))
643        (unless (typep thing type)        (unless (typep thing type)
644          (error "~:R argument is not a ~S: ~S." n type spec))          (error _"~:R argument is not a ~S: ~S." n type spec))
645        thing)))        thing)))
646    
647    
# Line 656  Line 658 
658    (let ((dspec (if (atom spec) (list spec 0) spec)))    (let ((dspec (if (atom spec) (list spec 0) spec)))
659      (unless (and (= (length dspec) 2)      (unless (and (= (length dspec) 2)
660                   (typep (second dspec) 'unsigned-byte))                   (typep (second dspec) 'unsigned-byte))
661        (error "Malformed time specifier: ~S." spec))        (error _"Malformed time specifier: ~S." spec))
662    
663      (cons (case (first dspec)      (cons (case (first dspec)
664              (:load 0)              (:load 0)
# Line 665  Line 667 
667              (:result 3)              (:result 3)
668              (:save 4)              (:save 4)
669              (t              (t
670               (error "Unknown phase in time specifier: ~S." spec)))               (error _"Unknown phase in time specifier: ~S." spec)))
671            (second dspec))))            (second dspec))))
672    
673    
# Line 711  Line 713 
713        (dolist (op (vop-parse-operands parse))        (dolist (op (vop-parse-operands parse))
714          (when (operand-parse-target op)          (when (operand-parse-target op)
715            (unless (member (operand-parse-kind op) '(:argument :temporary))            (unless (member (operand-parse-kind op) '(:argument :temporary))
716              (error "Cannot target a ~S operand: ~S." (operand-parse-kind op)              (error _"Cannot target a ~S operand: ~S." (operand-parse-kind op)
717                     (operand-parse-name op)))                     (operand-parse-name op)))
718            (let ((target (find-operand (operand-parse-target op) parse            (let ((target (find-operand (operand-parse-target op) parse
719                                        '(:temporary :result))))                                        '(:temporary :result))))
# Line 800  Line 802 
802                       (found (or (assoc alt (funs) :test #'member)                       (found (or (assoc alt (funs) :test #'member)
803                                  (rassoc name (funs)))))                                  (rassoc name (funs)))))
804                  (unless name                  (unless name
805                    (error "No move function defined to ~:[save~;load~] SC ~S~                    (error _"No move function defined to ~:[save~;load~] SC ~S~
806                            ~:[to~;from~] from SC ~S."                            ~:[to~;from~] from SC ~S."
807                           load-p sc-name load-p (sc-name alt)))                           load-p sc-name load-p (sc-name alt)))
808    
809                  (cond (found                  (cond (found
810                         (unless (eq (cdr found) name)                         (unless (eq (cdr found) name)
811                           (error "Can't tell whether to ~:[save~;load~] with ~S~@                           (error _"Can't tell whether to ~:[save~;load~] with ~S~@
812                                   or ~S when operand is in SC ~S."                                   or ~S when operand is in SC ~S."
813                                  load-p name (cdr found) (sc-name alt)))                                  load-p name (cdr found) (sc-name alt)))
814                         (pushnew alt (car found)))                         (pushnew alt (car found)))
# Line 814  Line 816 
816                         (funs (cons (list alt) name))))))))                         (funs (cons (list alt) name))))))))
817           ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))           ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
818           (t           (t
819            (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@            (error _"SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
820                    mentioned in the restriction for operand ~S."                    mentioned in the restriction for operand ~S."
821                   sc-name load-p (operand-parse-name op))))))                   sc-name load-p (operand-parse-name op))))))
822      (funs)))      (funs)))
# Line 853  Line 855 
855                `(when (eq ,load-tn ,(operand-parse-name op))                `(when (eq ,load-tn ,(operand-parse-name op))
856                   ,form)))                   ,form)))
857          `(when ,load-tn          `(when ,load-tn
858             (error "Load TN allocated, but no move function?~@             (error _"Load TN allocated, but no move function?~@
859                     VM definition inconsistent, recompile and try again.")))))                     VM definition inconsistent, recompile and try again.")))))
860    
861  ;;; DECIDE-TO-LOAD  --  Internal  ;;; DECIDE-TO-LOAD  --  Internal
# Line 955  Line 957 
957      (collect ((operands))      (collect ((operands))
958        (dolist (spec specs)        (dolist (spec specs)
959          (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))          (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
960            (error "Malformed operand specifier: ~S." spec))            (error _"Malformed operand specifier: ~S." spec))
961          (when more          (when more
962            (error "More operand isn't last: ~S." specs))            (error _"More operand isn't last: ~S." specs))
963          (let* ((name (first spec))          (let* ((name (first spec))
964                 (old (if (vop-parse-inherits parse)                 (old (if (vop-parse-inherits parse)
965                          (find-operand name                          (find-operand name
# Line 1010  Line 1012 
1012                   (setf (operand-parse-target res) value))                   (setf (operand-parse-target res) value))
1013                  (:from                  (:from
1014                   (unless (eq kind :result)                   (unless (eq kind :result)
1015                     (error "Can only specify :FROM in a result: ~S" spec))                     (error _"Can only specify :FROM in a result: ~S" spec))
1016                   (setf (operand-parse-born res) (parse-time-spec value)))                   (setf (operand-parse-born res) (parse-time-spec value)))
1017                  (:to                  (:to
1018                   (unless (eq kind :argument)                   (unless (eq kind :argument)
1019                     (error "Can only specify :TO in an argument: ~S" spec))                     (error _"Can only specify :TO in an argument: ~S" spec))
1020                   (setf (operand-parse-dies res) (parse-time-spec value)))                   (setf (operand-parse-dies res) (parse-time-spec value)))
1021                  (t                  (t
1022                   (error "Unknown keyword in operand specifier: ~S." spec)))))                   (error _"Unknown keyword in operand specifier: ~S." spec)))))
1023    
1024            (cond ((not more)            (cond ((not more)
1025                   (operands res))                   (operands res))
1026                  ((operand-parse-target more)                  ((operand-parse-target more)
1027                   (error "Cannot specify :TARGET in a :MORE operand."))                   (error _"Cannot specify :TARGET in a :MORE operand."))
1028                  ((operand-parse-load more)                  ((operand-parse-load more)
1029                   (error "Cannot specify :LOAD-IF in a :MORE operand.")))))                   (error _"Cannot specify :LOAD-IF in a :MORE operand.")))))
1030        (values (the list (operands)) more))))        (values (the list (operands)) more))))
1031    
1032    
# Line 1038  Line 1040 
1040             (type vop-parse parse))             (type vop-parse parse))
1041    (let ((len (length spec)))    (let ((len (length spec)))
1042      (unless (>= len 2)      (unless (>= len 2)
1043        (error "Malformed temporary spec: ~S." spec))        (error _"Malformed temporary spec: ~S." spec))
1044      (unless (listp (second spec))      (unless (listp (second spec))
1045        (error "Malformed options list: ~S." (second spec)))        (error _"Malformed options list: ~S." (second spec)))
1046      (unless (evenp (length (second spec)))      (unless (evenp (length (second spec)))
1047        (error "Odd number of arguments in keyword options: ~S." spec))        (error _"Odd number of arguments in keyword options: ~S." spec))
1048      (unless (consp (cddr spec))      (unless (consp (cddr spec))
1049        (warn "Temporary spec allocates no temps:~%  ~S" spec))        (warn _"Temporary spec allocates no temps:~%  ~S" spec))
1050      (dolist (name (cddr spec))      (dolist (name (cddr spec))
1051        (unless (symbolp name)        (unless (symbolp name)
1052          (error "Bad temporary name: ~S." name))          (error _"Bad temporary name: ~S." name))
1053        (let ((res (make-operand-parse :name name  :kind :temporary        (let ((res (make-operand-parse :name name  :kind :temporary
1054                                       :temp-temp (gensym)                                       :temp-temp (gensym)
1055                                       :born (parse-time-spec :load)                                       :born (parse-time-spec :load)
# Line 1074  Line 1076 
1076              (:scs              (:scs
1077               (let ((scs (vop-spec-arg opt 'list 1 nil)))               (let ((scs (vop-spec-arg opt 'list 1 nil)))
1078                 (unless (= (length scs) 1)                 (unless (= (length scs) 1)
1079                   (error "Must specify exactly one SC for a temporary."))                   (error _"Must specify exactly one SC for a temporary."))
1080                 (setf (operand-parse-sc res) (first scs))))                 (setf (operand-parse-sc res) (first scs))))
1081              (:type)              (:type)
1082              (t              (t
1083               (error "Unknown temporary option: ~S." opt))))               (error _"Unknown temporary option: ~S." opt))))
1084    
1085          (unless (and (time-spec-order (operand-parse-dies res)          (unless (and (time-spec-order (operand-parse-dies res)
1086                                        (operand-parse-born res))                                        (operand-parse-born res))
1087                       (not (time-spec-order (operand-parse-born res)                       (not (time-spec-order (operand-parse-born res)
1088                                             (operand-parse-dies res))))                                             (operand-parse-dies res))))
1089            (error "Temporary lifetime doesn't begin before it ends: ~S." spec))            (error _"Temporary lifetime doesn't begin before it ends: ~S." spec))
1090    
1091          (unless (operand-parse-sc res)          (unless (operand-parse-sc res)
1092            (error "Must specifiy :SC for all temporaries: ~S" spec))            (error _"Must specifiy :SC for all temporaries: ~S" spec))
1093    
1094          (setf (vop-parse-temps parse)          (setf (vop-parse-temps parse)
1095                (cons res                (cons res
# Line 1105  Line 1107 
1107    (declare (type vop-parse parse) (list specs))    (declare (type vop-parse parse) (list specs))
1108    (dolist (spec specs)    (dolist (spec specs)
1109      (unless (consp spec)      (unless (consp spec)
1110        (error "Malformed option specification: ~S." spec))        (error _"Malformed option specification: ~S." spec))
1111      (case (first spec)      (case (first spec)
1112        (:args        (:args
1113         (multiple-value-bind         (multiple-value-bind
# Line 1175  Line 1177 
1177               (vop-spec-arg spec               (vop-spec-arg spec
1178                             '(member t nil :compute-only :force-to-stack))))                             '(member t nil :compute-only :force-to-stack))))
1179        (t        (t
1180         (error "Unknown option specifier: ~S." (first spec)))))         (error _"Unknown option specifier: ~S." (first spec)))))
1181    (undefined-value))    (undefined-value))
1182    
1183    
# Line 1210  Line 1212 
1212                             (aref (sc-load-costs load-sc) op-scn)                             (aref (sc-load-costs load-sc) op-scn)
1213                             (aref (sc-load-costs op-sc) load-scn))))                             (aref (sc-load-costs op-sc) load-scn))))
1214              (unless load              (unless load
1215                (error "No move function defined to move ~:[from~;to~] SC ~                (error _"No move function defined to move ~:[from~;to~] SC ~
1216                        ~S~%~:[to~;from~] alternate or constant SC ~S."                        ~S~%~:[to~;from~] alternate or constant SC ~S."
1217                       load-p sc-name load-p (sc-name op-sc)))                       load-p sc-name load-p (sc-name op-sc)))
1218    
# Line 1311  Line 1313 
1313                            (parse-operand-type alias)                            (parse-operand-type alias)
1314                            `(:or ,spec))))                            `(:or ,spec))))
1315                     ((atom spec)                     ((atom spec)
1316                      (error "Bad thing to be a operand type: ~S." spec))                      (error _"Bad thing to be a operand type: ~S." spec))
1317                     (t                     (t
1318                      (case (first spec)                      (case (first spec)
1319                        (:or                        (:or
# Line 1319  Line 1321 
1321                           (results :or)                           (results :or)
1322                           (dolist (item (cdr spec))                           (dolist (item (cdr spec))
1323                             (unless (symbolp item)                             (unless (symbolp item)
1324                               (error "Bad PRIMITIVE-TYPE name in ~S: ~S"                               (error _"Bad PRIMITIVE-TYPE name in ~S: ~S"
1325                                      spec item))                                      spec item))
1326                             (let ((alias                             (let ((alias
1327                                    (gethash item                                    (gethash item
# Line 1328  Line 1330 
1330                               (if alias                               (if alias
1331                                   (let ((alias (parse-operand-type alias)))                                   (let ((alias (parse-operand-type alias)))
1332                                     (unless (eq (car alias) :or)                                     (unless (eq (car alias) :or)
1333                                       (error "Can't include primitive-type ~                                       (error _"Can't include primitive-type ~
1334                                               alias ~S in a :OR restriction: ~S."                                               alias ~S in a :OR restriction: ~S."
1335                                              item spec))                                              item spec))
1336                                     (dolist (x (cdr alias))                                     (dolist (x (cdr alias))
# Line 1339  Line 1341 
1341                                              :start 1)))                                              :start 1)))
1342                        (:constant                        (:constant
1343                         (unless args-p                         (unless args-p
1344                           (error "Can't :CONSTANT for a result."))                           (error _"Can't :CONSTANT for a result."))
1345                         (unless (= (length spec) 2)                         (unless (= (length spec) 2)
1346                           (error "Bad :CONSTANT argument type spec: ~S." spec))                           (error _"Bad :CONSTANT argument type spec: ~S." spec))
1347                         spec)                         spec)
1348                        (t                        (t
1349                         (error "Bad thing to be a operand type: ~S." spec)))))))                         (error _"Bad thing to be a operand type: ~S." spec)))))))
1350      (mapcar #'parse-operand-type specs)))      (mapcar #'parse-operand-type specs)))
1351    
1352    
# Line 1372  Line 1374 
1374                                  (meta-primitive-type-or-lose ptype))                                  (meta-primitive-type-or-lose ptype))
1375                                 nil)                                 nil)
1376                      (when (svref load-scs rep) (return t)))                      (when (svref load-scs rep) (return t)))
1377              (error "In the ~A ~:[result~;argument~] to VOP ~S,~@              (error _"In the ~A ~:[result~;argument~] to VOP ~S,~@
1378                      none of the SCs allowed by the operand type ~S can ~                      none of the SCs allowed by the operand type ~S can ~
1379                      directly be loaded~@                      directly be loaded~@
1380                      into any of the restriction's SCs:~%  ~S~:[~;~@                      into any of the restriction's SCs:~%  ~S~:[~;~@
# Line 1388  Line 1390 
1390                               (meta-sc-or-lose sc)                               (meta-sc-or-lose sc)
1391                               (meta-primitive-type-or-lose ptype))                               (meta-primitive-type-or-lose ptype))
1392                          (return t))))                          (return t))))
1393            (warn "~:[Result~;Argument~] ~A to VOP ~S~@            (warn _"~:[Result~;Argument~] ~A to VOP ~S~@
1394                   has SC restriction ~S which is ~                   has SC restriction ~S which is ~
1395                   not allowed by the operand type:~%  ~S"                   not allowed by the operand type:~%  ~S"
1396                  load-p (operand-parse-name op) (vop-parse-name parse)                  load-p (operand-parse-name op) (vop-parse-name parse)
# Line 1412  Line 1414 
1414                                          (eq (car x) :constant)))                                          (eq (car x) :constant)))
1415                                 types)                                 types)
1416                   num)                   num)
1417          (error "Expected ~D ~:[result~;argument~] type~P: ~S."          (error _"Expected ~D ~:[result~;argument~] type~P: ~S."
1418                 num load-p types num)))                 num load-p types num)))
1419    
1420      (when more-op      (when more-op
1421        (let ((mtype (car (last types))))        (let ((mtype (car (last types))))
1422          (when (and (consp mtype) (eq (first mtype) :constant))          (when (and (consp mtype) (eq (first mtype) :constant))
1423            (error "Can't use :CONSTANT on VOP more args.")))))            (error _"Can't use :CONSTANT on VOP more args.")))))
1424    
1425    (when (vop-parse-translate parse)    (when (vop-parse-translate parse)
1426      (let ((types (specify-operand-types types ops more-op)))      (let ((types (specify-operand-types types ops more-op)))
# Line 1589  Line 1591 
1591    
1592      (let ((nvars (length (vop-parse-variant-vars parse))))      (let ((nvars (length (vop-parse-variant-vars parse))))
1593        (unless (= (length variant) nvars)        (unless (= (length variant) nvars)
1594          (error "Expected ~D variant values: ~S." nvars variant)))          (error _"Expected ~D variant values: ~S." nvars variant)))
1595    
1596      `(make-vop-info      `(make-vop-info
1597        :name ',(vop-parse-name parse)        :name ',(vop-parse-name parse)
# Line 1621  Line 1623 
1623  ;;; inheritance by copying the VOP-Parse structure for the inherited structure.  ;;; inheritance by copying the VOP-Parse structure for the inherited structure.
1624  ;;;  ;;;
1625  (defmacro define-vop ((name &optional inherits) &rest specs)  (defmacro define-vop ((name &optional inherits) &rest specs)
1626    "Define-VOP (Name [Inherits]) Spec*    _N"Define-VOP (Name [Inherits]) Spec*
1627    Define the symbol Name to be a Virtual OPeration in the compiler.  If    Define the symbol Name to be a Virtual OPeration in the compiler.  If
1628    specified, Inherits is the name of a VOP that we default unspecified    specified, Inherits is the name of a VOP that we default unspecified
1629    information from.  Each Spec is a list beginning with a keyword indicating    information from.  Each Spec is a list beginning with a keyword indicating
# Line 1837  Line 1839 
1839  ;;; Emit-Template  -- Interface  ;;; Emit-Template  -- Interface
1840  ;;;  ;;;
1841  (defmacro emit-template (node block template args results &optional info)  (defmacro emit-template (node block template args results &optional info)
1842    "Emit-Template Node Block Template Args Results [Info]    _N"Emit-Template Node Block Template Args Results [Info]
1843    Call the emit function for Template, linking the result in at the end of    Call the emit function for Template, linking the result in at the end of
1844    Block."    Block."
1845    (let ((n-first (gensym))    (let ((n-first (gensym))
# Line 1856  Line 1858 
1858  ;;; VOP  --  Interface  ;;; VOP  --  Interface
1859  ;;;  ;;;
1860  (defmacro vop (name node block &rest operands)  (defmacro vop (name node block &rest operands)
1861    "VOP Name Node Block Arg* Info* Result*    _N"VOP Name Node Block Arg* Info* Result*
1862    Emit the VOP (or other template) Name at the end of the IR2-Block Block,    Emit the VOP (or other template) Name at the end of the IR2-Block Block,
1863    using Node for the source context.  The interpretation of the remaining    using Node for the source context.  The interpretation of the remaining
1864    arguments depends on the number of operands of various kinds that are    arguments depends on the number of operands of various kinds that are
# Line 1878  Line 1880 
1880           (n-template (gensym)))           (n-template (gensym)))
1881    
1882      (when (or (vop-parse-more-args parse) (vop-parse-more-results parse))      (when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
1883        (error "Cannot use VOP with variable operand count templates."))        (error _"Cannot use VOP with variable operand count templates."))
1884      (unless (= noperands (length operands))      (unless (= noperands (length operands))
1885        (error "Called with ~D operands, but was expecting ~D."        (error _"Called with ~D operands, but was expecting ~D."
1886               (length operands) noperands))               (length operands) noperands))
1887    
1888      (multiple-value-bind      (multiple-value-bind
# Line 1915  Line 1917 
1917  ;;; VOP*  --  Interface  ;;; VOP*  --  Interface
1918  ;;;  ;;;
1919  (defmacro vop* (name node block args results &rest info)  (defmacro vop* (name node block args results &rest info)
1920    "VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*    _N"VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
1921    Like VOP, but allows for emission of templates with arbitrary numbers of    Like VOP, but allows for emission of templates with arbitrary numbers of
1922    arguments, and for emission of templates using already-created TN-Ref lists.    arguments, and for emission of templates using already-created TN-Ref lists.
1923    
# Line 1941  Line 1943 
1943    
1944      (unless (or (vop-parse-more-args parse)      (unless (or (vop-parse-more-args parse)
1945                  (<= (length fixed-args) arg-count))                  (<= (length fixed-args) arg-count))
1946        (error "Too many fixed arguments."))        (error _"Too many fixed arguments."))
1947      (unless (or (vop-parse-more-results parse)      (unless (or (vop-parse-more-results parse)
1948                  (<= (length fixed-results) result-count))                  (<= (length fixed-results) result-count))
1949        (error "Too many fixed results."))        (error _"Too many fixed results."))
1950      (unless (= (length info) info-count)      (unless (= (length info) info-count)
1951        (error "Expected ~D info args." info-count))        (error _"Expected ~D info args." info-count))
1952    
1953      (multiple-value-bind      (multiple-value-bind
1954          (acode abinds n-args)          (acode abinds n-args)
# Line 1973  Line 1975 
1975  ;;; SC-Case  --  Public  ;;; SC-Case  --  Public
1976  ;;;  ;;;
1977  (defmacro sc-case (tn &rest forms)  (defmacro sc-case (tn &rest forms)
1978    "SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*    _N"SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
1979    Case off of TN's SC.  The first clause containing TN's SC is evaulated,    Case off of TN's SC.  The first clause containing TN's SC is evaulated,
1980    returning the values of the last form.  A clause beginning with T specifies a    returning the values of the last form.  A clause beginning with T specifies a
1981    default.  If it appears, it must be last.  If no default is specified, and no    default.  If it appears, it must be last.  If no default is specified, and no
# Line 1983  Line 1985 
1985      (collect ((clauses))      (collect ((clauses))
1986        (do ((cases forms (rest cases)))        (do ((cases forms (rest cases)))
1987            ((null cases)            ((null cases)
1988             (clauses `(t (error "Unknown SC to SC-Case for ~S:~%  ~S" ,n-tn             (clauses `(t (error _"Unknown SC to SC-Case for ~S:~%  ~S" ,n-tn
1989                                 (sc-name (tn-sc ,n-tn))))))                                 (sc-name (tn-sc ,n-tn))))))
1990          (let ((case (first cases)))          (let ((case (first cases)))
1991            (when (atom case)            (when (atom case)
1992              (error "Illegal SC-Case clause: ~S." case))              (error _"Illegal SC-Case clause: ~S." case))
1993            (let ((head (first case)))            (let ((head (first case)))
1994              (when (eq head t)              (when (eq head t)
1995                (when (rest cases)                (when (rest cases)
1996                  (error "T case is not last in SC-Case."))                  (error _"T case is not last in SC-Case."))
1997                (clauses `(t nil ,@(rest case)))                (clauses `(t nil ,@(rest case)))
1998                (return))                (return))
1999              (clauses `((or ,@(mapcar #'(lambda (x)              (clauses `((or ,@(mapcar #'(lambda (x)
# Line 2008  Line 2010 
2010  ;;; SC-Is  --  Interface  ;;; SC-Is  --  Interface
2011  ;;;  ;;;
2012  (defmacro sc-is (tn &rest scs)  (defmacro sc-is (tn &rest scs)
2013    "SC-Is TN SC*    _N"SC-Is TN SC*
2014    Returns true if TNs SC is any of the named SCs, false otherwise."    Returns true if TNs SC is any of the named SCs, false otherwise."
2015    (once-only ((n-sc `(sc-number (tn-sc ,tn))))    (once-only ((n-sc `(sc-number (tn-sc ,tn))))
2016      `(or ,@(mapcar #'(lambda (x)      `(or ,@(mapcar #'(lambda (x)
# Line 2019  Line 2021 
2021  ;;;  ;;;
2022  (defmacro do-ir2-blocks ((block-var component &optional result)  (defmacro do-ir2-blocks ((block-var component &optional result)
2023                           &body forms)                           &body forms)
2024    "Do-IR2-Blocks (Block-Var Component [Result]) Form*    _N"Do-IR2-Blocks (Block-Var Component [Result]) Form*
2025    Iterate over the IR2 blocks in component, in emission order."    Iterate over the IR2 blocks in component, in emission order."
2026    `(do ((,block-var (block-info (component-head ,component))    `(do ((,block-var (block-info (component-head ,component))
2027                      (ir2-block-next ,block-var)))                      (ir2-block-next ,block-var)))
# Line 2030  Line 2032 
2032  ;;; DO-LIVE-TNS  --  Interface  ;;; DO-LIVE-TNS  --  Interface
2033  ;;;  ;;;
2034  (defmacro do-live-tns ((tn-var live block &optional result) &body body)  (defmacro do-live-tns ((tn-var live block &optional result) &body body)
2035    "DO-LIVE-TNS (TN-Var Live Block [Result]) Form*    _N"DO-LIVE-TNS (TN-Var Live Block [Result]) Form*
2036    Iterate over all the TNs live at some point, with the live set represented by    Iterate over all the TNs live at some point, with the live set represented by
2037    a local conflicts bit-vector and the IR2-Block containing the location."    a local conflicts bit-vector and the IR2-Block containing the location."
2038    (let ((n-conf (gensym))    (let ((n-conf (gensym))
# Line 2073  Line 2075 
2075  ;;;  ;;;
2076  (defmacro do-environment-ir2-blocks ((block-var env &optional result)  (defmacro do-environment-ir2-blocks ((block-var env &optional result)
2077                                       &body body)                                       &body body)
2078    "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form*    _N"DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form*
2079    Iterate over all the IR2 blocks in the environment Env, in emit order."    Iterate over all the IR2 blocks in the environment Env, in emit order."
2080    (once-only ((n-env env))    (once-only ((n-env env))
2081      (once-only ((n-first `(node-block      (once-only ((n-first `(node-block

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.9.48.2

  ViewVC Help
Powered by ViewVC 1.1.5