0.8.3.94:

[sbcl.git] / src / compiler / meta-vmdef.lisp

diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp
index 7d5b1bb..25326ad 100644 (file)
--- a/src/compiler/meta-vmdef.lisp
+++ b/src/compiler/meta-vmdef.lisp
@@ -275,8 +275,7 @@
 ;;; type descriptor for the Lisp type that is equivalent to this type.
 (defmacro !def-primitive-type (name scs &key (type name))
   (declare (type symbol name) (type list scs))
-  (let ((scns (mapcar #'meta-sc-number-or-lose scs))
-       (ctype-form `(specifier-type ',type)))
+  (let ((scns (mapcar #'meta-sc-number-or-lose scs)))
     `(progn
        (/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..")
        (/primitive-print ,(symbol-name name))
@@ -284,9 +283,8 @@
         (setf (gethash ',name *backend-meta-primitive-type-names*)
               (make-primitive-type :name ',name
                                    :scs ',scns
-                                   :type ,ctype-form)))
-       ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))
-                   (n-type ctype-form))
+                                   :specifier ',type)))
+       ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*)))
          `(progn
             ;; If the PRIMITIVE-TYPE structure already exists, we
             ;; destructively modify it so that existing references in
@@ -300,13 +298,13 @@
             (cond (,n-old
                    (/show0 "in ,N-OLD clause of COND")
                    (setf (primitive-type-scs ,n-old) ',scns)
-                   (setf (primitive-type-type ,n-old) ,n-type))
+                   (setf (primitive-type-specifier ,n-old) ',type))
                   (t
                    (/show0 "in T clause of COND")
                    (setf (gethash ',name *backend-primitive-type-names*)
                          (make-primitive-type :name ',name
                                               :scs ',scns
-                                              :type ,n-type))))
+                                              :specifier ',type))))
             (/show0 "done with !DEF-PRIMITIVE-TYPE")
             ',name)))))
 
@@ -681,8 +679,16 @@
                                       nil)
                                   t)))
                           :key #'car))
-            (oe-type '(mod #.max-vop-tn-refs)) ; :REF-ORDERING element type
-            (te-type '(mod #.(* max-vop-tn-refs 2))) ; :TARGETS element type
+            ;; :REF-ORDERING element type
+            ;;
+            ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right
+            (oe-type '(unsigned-byte 8))
+            ;; :TARGETS element-type
+            ;;
+            ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does
+            ;; not correspond to the definition in
+            ;; src/compiler/vop.lisp.
+            (te-type '(unsigned-byte 16))
             (ordering (make-specializable-array
                        (length sorted)
                        :element-type oe-type)))
@@ -748,13 +754,13 @@
                                (rassoc name (funs)))))
                (unless name
                  (error "no move function defined to ~:[save~;load~] SC ~S ~
-                         with ~S ~:[to~;from~] from SC ~S"
+                         ~:[to~;from~] from SC ~S"
                         load-p sc-name load-p (sc-name alt)))
                
                (cond (found
                       (unless (eq (cdr found) name)
                         (error "can't tell whether to ~:[save~;load~]~@
-                                or ~S when operand is in SC ~S"
+                                with ~S or ~S when operand is in SC ~S"
                                load-p name (cdr found) (sc-name alt)))
                       (pushnew alt (car found)))
                      (t
@@ -1504,11 +1510,11 @@
 ;;;     are defaulted from the inherited argument (or result) of the same
 ;;;     name. The following operand options are defined:
 ;;;
-;;; :SCs (SC*)
-;;;     :SCs specifies good SCs for this operand. Other SCs will be
-;;;    penalized according to move costs. A load TN will be allocated if
-;;;    necessary, guaranteeing that the operand is always one of the
-;;;    specified SCs.
+;;;     :SCs (SC*)
+;;;         :SCs specifies good SCs for this operand. Other SCs will
+;;;         be penalized according to move costs. A load TN will be
+;;;         allocated if necessary, guaranteeing that the operand is
+;;;         always one of the specified SCs.
 ;;;
 ;;;     :LOAD-TN Load-Name
 ;;;         Load-Name is bound to the load TN allocated for this