diff --git a/compiler/old-rt/vm.lisp b/compiler/old-rt/vm.lisp
index 3103d2e6e0b5dd949f134417f92eb354b85c09fa..037472a699dd8caf15d729658def6ea3b97b1821 100644
--- a/compiler/old-rt/vm.lisp
+++ b/compiler/old-rt/vm.lisp
@@ -137,7 +137,7 @@
 	  (t *any-primitive-type*))))
 
 
-;;; Primitive-Type  --  Interface
+;;; PRIMITIVE-TYPE  --  Interface
 ;;;
 ;;;    Return the primitive type corresponding to a type descriptor structure.
 ;;; If a fixnum or an interesting simple vector, then return the appropriate
@@ -147,9 +147,36 @@
 ;;; In a bootstrapping situation, we should be careful to use the correct
 ;;; values for the system parameters.
 ;;;
-(defun primitive-type (type)
+;;; Note: DEFUN-CACHED caches this translation; If the primitive type
+;;; translation is ever changed (due to hardware configuration switches, etc.),
+;;; then PRIMITIVE-TYPE-CACHE-CLEAR must be called to clear old cached
+;;; information.
+;;;
+(defun-cached (primitive-type
+	       :hash-function (lambda (x)
+				(logand (cache-hash-eq x) #x1FF))
+	       :hash-bits 9
+	       :values 2
+	       :default (values nil :empty))
+	      ((type eq))
   (declare (type ctype type))
   (etypecase type
+    (named-type
+     (case (named-type-name type)
+       ((t bignum ratio string-char function)
+	(values (primitive-type-or-lose (named-type-name type)) t))
+       (cons
+	(values (primitive-type-or-lose 'list) nil))
+       (standard-char
+	(values (primitive-type-or-lose 'string-char) nil))
+       (t
+	(values *any-primitive-type* nil))))
+    (member-type
+     (let* ((members (member-type-members type))
+	    (res (primitive-type-of (first members))))
+       (dolist (mem (rest members) (values res nil))
+	 (unless (eq (primitive-type-of mem) res)
+	   (return (values *any-primitive-type* nil))))))
     (numeric-type
      (if (not (eq (numeric-type-complexp type) :real))
 	 (values *any-primitive-type* nil)
@@ -198,22 +225,6 @@
 		 (unless ptype-exact (setq exact nil))
 		 (unless (eq ptype res)
 		   (return (values *any-primitive-type* nil)))))))))
-    (member-type
-     (let* ((members (member-type-members type))
-	    (res (primitive-type-of (first members))))
-       (dolist (mem (rest members) (values res nil))
-	 (unless (eq (primitive-type-of mem) res)
-	   (return (values *any-primitive-type* nil))))))
-    (named-type
-     (case (named-type-name type)
-       ((t bignum ratio string-char function)
-	(values (primitive-type-or-lose (named-type-name type)) t))
-       (cons
-	(values (primitive-type-or-lose 'list) nil))
-       (standard-char
-	(values (primitive-type-or-lose 'string-char) nil))
-       (t
-	(values *any-primitive-type* nil))))
     (ctype
      (values *any-primitive-type* nil))))