diff --git a/assembly/assemfile.lisp b/assembly/assemfile.lisp
index 99f20bde40533b4a3be4784055ac3ba1d91bafbd..2a7c429f9899fade39814cd8855873349409fab5 100644
--- a/assembly/assemfile.lisp
+++ b/assembly/assemfile.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/assemfile.lisp,v 1.9 1990/04/27 19:21:01 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/assemfile.lisp,v 1.10 1990/05/23 06:03:16 wlott Exp $
 ;;;
 ;;; This file contains the extra code necessary to feed an entire file of
 ;;; assembly code to the assembler.
@@ -24,9 +24,11 @@
 (defvar *assembler-routines* nil
   "A List of (name . label) for every entry point.")
 
-(defun assemble-file (name &key (output-file
-				 (make-pathname :defaults name
-						:type "mips-fasl")))
+(defun assemble-file (name &key
+			   (output-file
+			    (make-pathname :defaults name
+					   :type "mips-fasl"))
+			   trace-file)
   (let* ((*do-assembly* t)
 	 (name (pathname name))
 	 (*lap-output-file* (open-fasl-file (pathname output-file) name))
@@ -45,6 +47,16 @@
 				     length
 				     *assembler-routines*
 				     *lap-output-file*))
+	  (when trace-file
+	    (with-open-file (file (if (eq trace-file t)
+				      (make-pathname :defaults name
+						     :type "trace")
+				      trace-file)
+				  :direction :output
+				  :if-exists :supersede)
+	      (format file "Assembly listing for ~A:~3%" (namestring name))
+	      (dump-segment *code-segment* file)
+	      (fresh-line file)))
 	  (setq won t))
       (close-fasl-file *lap-output-file* (not won)))
     won))
@@ -53,158 +65,29 @@
 
 (defstruct (reg-spec
 	    (:print-function %print-reg-spec))
-  (kind :temp :type '(member :arg :temp :result))
-  (name nil :type 'symbol)
-  (temp nil :type '(or null reg-spec))
-  (sc nil :type '(or null sc))
-  (offset nil :type '(or null fixnum))
-  (type nil :type '(or null symbol))
-  (from '(:eval 1))
-  (to '(:eval 2))
-  (keys :type 'list))
+  (kind :temp :type (member :arg :temp :result))
+  (name nil :type symbol)
+  (temp nil :type symbol)
+  (sc nil :type symbol)
+  (offset 0 :type fixnum))
 
 (defun %print-reg-spec (spec stream depth)
   (declare (ignore depth))
-  (macrolet ((maybe (fn arg)
-	       (let ((var (gensym)))
-		 `(let ((,var ,arg))
-		    (when ,var (,fn ,var))))))
-    (format stream
-	    "#<reg ~S ~S~@[[~S]~]~@[ sc=~S~]~@[ offset=~S~]~@[ type=~S~]>"
-	    (reg-spec-kind spec)
-	    (reg-spec-name spec)
-	    (reg-spec-temp spec)
-	    (maybe sc-name (reg-spec-sc spec))
-	    (reg-spec-offset spec)
-	    (reg-spec-type spec))))
+  (format stream
+	  "#<reg ~S ~S sc=~S offset=~S>"
+	  (reg-spec-kind spec)
+	  (reg-spec-name spec)
+	  (reg-spec-sc spec)
+	  (reg-spec-offset spec)))
 
-(defun parse-reg-spec (kind name &rest keys &key sc offset type
-			    (from '(:eval 1)) (to '(:eval 2))
-			    &allow-other-keys)
-  (make-reg-spec :kind kind
-		 :name name
-		 :sc (if sc (sc-or-lose sc))
-		 :offset (eval offset)
-		 :type type
-		 :from from
-		 :to to
-		 :keys keys))
 
-
-(defvar *allocated-regs* nil)
-(defvar *available-storage-bases* nil)
-(defvar *available-storage-classes* nil)
-
-(defun allocate (reg offset)
-  (let* ((sc (reg-spec-sc reg))
-	 (sb (sc-sb sc))
-	 (avail (find sb *available-storage-bases* :key #'car)))
-    (unless (member offset avail)
-      (let ((conflict (find-if #'(lambda (other)
-				   (and (eq (sc-sb (reg-spec-sc other)) sb)
-					(= (reg-spec-offset other) offset)))
-			       *allocated-regs*)))
-	(if conflict
-	    (error "Attempt to allocate ~S on top of ~S." reg conflict)
-	    (error "Attempted to allocate ~S in ~S at ~S, but ~:*~S is an ~
-	            invalid offset."
-		   reg sc offset))))
-    ;; Note: we will never try to delete the first element 'cause it is
-    ;; the storage base itself.
-    (delete offset avail)
-    (setf (reg-spec-offset reg) offset)
-    (push reg *allocated-regs*)))
-
-
-(defun make-arg-temp (name sc offset)
-  (parse-reg-spec :temp (make-symbol (symbol-name name))
-		  :sc sc
-		  :offset offset
-		  :from '(:eval 0)
-		  :to '(:eval 2)))
-
-(defun allocate-regs (regs)
-  (let ((*allocated-regs* nil)
-	(*available-storage-bases* nil)
-	(*available-storage-classes* (list (sc-or-lose 'descriptor-reg))))
-    ;; First, find all the storage classes that are refered to.
-    (dolist (reg regs)
-      (when (reg-spec-sc reg)
-	(pushnew (reg-spec-sc reg) *available-storage-classes*)))
-    ;; Second, find all the storage bases that are used by them and
-    ;; record what locations are available.
-    (dolist (sc *available-storage-classes*)
-      (let ((sb (sc-sb sc)))
-	(unless (find sb *available-storage-bases*
-		      :key #'car)
-	  (let ((list (list sb)))
-	    (dotimes (i (sb-size sb))
-	      (push i list))
-	    (push (nreverse list)
-		  *available-storage-bases*)))))
-    ;; Third, allocate the wired regs.
-    #+nil
-    (dolist (reg regs)
-      (when (reg-spec-offset reg)
-	(allocate reg (reg-spec-offset reg))))
-    ;; Fourth, make wired temp regs for the args and results.
-    (let* ((arg-temps (mapcar #'(lambda (name offset)
-				  (make-arg-temp name 'descriptor-reg offset))
-			      register-arg-names register-arg-offsets))
-	   (res-temps (copy-list arg-temps))
-	   (arg-index 0)
-	   (res-index 0))
-      (dolist (reg regs)
-	(macrolet ((next (list)
-		     `(if (reg-spec-offset reg)
-			  (make-arg-temp (reg-spec-name reg)
-					 (sc-name (reg-spec-sc reg))
-					 (reg-spec-offset reg))
-			  (pop ,list))))
-	  (case (reg-spec-kind reg)
-	    (:arg
-	     (let ((temp (next arg-temps)))
-	       (setf (reg-spec-temp reg) temp)
-	       (unless (member temp *allocated-regs*)
-		 (allocate temp (reg-spec-offset temp)))
-	       (setf (reg-spec-from temp)
-		     `(:argument ,arg-index)))
-	     (incf arg-index))
-	    (:res
-	     (let ((temp (next res-temps)))
-	       (setf (reg-spec-temp reg) temp)
-	       (unless (member temp *allocated-regs*)
-		 (allocate temp (reg-spec-offset temp)))
-	       (setf (reg-spec-to temp)
-		     `(:result ,res-index)))
-	     (incf res-index))
-	    (:temp
-	     (when (reg-spec-offset reg)
-	       (allocate reg (reg-spec-offset reg))))))))
-    ;; Fifth, remove regs we have already delt with.
-    (setf regs
-	  (remove-if #'(lambda (reg)
-			 (case (reg-spec-kind reg)
-			   ((:arg :res) t)
-			   (t (reg-spec-offset reg))))
-		     regs))
-    ;; Sixth, order the remaining regs based on the number of possibilities.
-    (assert (every #'reg-spec-sc regs) ()
-	    "All :TEMP regs must have a SC speced: ~S." regs)
-    (setf regs
-	  (sort (copy-list regs) #'<
-		:key #'(lambda (reg)
-			 (length (sc-locations (reg-spec-sc reg))))))
-    ;; Seventh, start picking.
-    (dolist (reg regs)
-      (let* ((sb (sc-sb (reg-spec-sc reg)))
-	     (possible (intersection (find sb *available-storage-bases*
-					   :key #'car)
-				     (sc-locations (reg-spec-sc reg))))
-	     (offset (car possible)))
-	(unless possible
-	  (error "Ran out of locations before allocating ~S" reg))
-	(allocate reg offset)))))
+(defun parse-reg-spec (kind name sc offset)
+  (let ((reg (make-reg-spec :kind kind :name name :sc sc :offset offset)))
+    (ecase kind
+      (:temp)
+      ((:arg :res)
+       (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
+    reg))
 
 
 (defun emit-assemble (name regs code)
@@ -225,11 +108,10 @@
 	 (emit-label ,name)
 	 (let (,@(mapcar
 		  #'(lambda (reg)
-		      (let ((temp (or (reg-spec-temp reg) reg)))
-			`(,(reg-spec-name reg)
-			  (make-random-tn
-			   :sc (sc-or-lose ',(sc-name (reg-spec-sc temp)))
-			   :offset ,(reg-spec-offset temp)))))
+		      `(,(reg-spec-name reg)
+			(make-random-tn
+			 :sc (sc-or-lose ',(reg-spec-sc reg))
+			 :offset ,(reg-spec-offset reg))))
 		  regs))
 	   ,@insts
 	   (inst addu lip-tn lra-tn (- vm:word-bytes vm:other-pointer-type))
@@ -239,76 +121,73 @@
 
 (defun arg-or-res-spec (reg)
   `(,(reg-spec-name reg)
-    :scs ,(if (reg-spec-sc reg)
-	      (list (sc-name (reg-spec-sc reg)))
-	      '(any-reg descriptor-reg))
+    :scs (,(reg-spec-sc reg))
     ,@(unless (eq (reg-spec-kind reg) :res)
-	`(:target ,(reg-spec-name (reg-spec-temp reg))))
-    ,@(do ((keys (reg-spec-keys reg) (cddr keys))
-	   (results nil (let ((key (car keys)))
-			  (if (member key '(:sc :offset))
-			      results
-			      (list* (cadr keys) key results)))))
-	  ((null keys) (nreverse results)))))
+	`(:target ,(reg-spec-temp reg)))))
 
-(defun emit-vop (name vars)
+(defun emit-vop (name options vars)
   (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
-	 (orig-temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
-	 (temps orig-temps)
+	 (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
 	 (results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
 	 (return-pc-label (make-symbol "RETURN-PC-LABEL"))
 	 (return-pc (make-symbol "RETURN-PC"))
 	 (lip (make-symbol "LIP"))
 	 (ndescr (make-symbol "NDESCR")))
-    (dolist (arg args)
-      (pushnew (reg-spec-temp arg) temps))
-    (dolist (res results)
-      (pushnew (reg-spec-temp res) temps))
-    `(define-vop (,name)
+    `(define-vop ,(if (atom name) (list name) name)
        (:args ,@(mapcar #'arg-or-res-spec args))
+       ,@(let ((index -1))
+	   (mapcar #'(lambda (arg)
+		       `(:temporary (:sc ,(reg-spec-sc arg)
+				     :offset ,(reg-spec-offset arg)
+				     :from (:argument ,(incf index))
+				     :to (:eval 2))
+				    ,(reg-spec-temp arg)))
+		   args))
        ,@(mapcar #'(lambda (temp)
-		     `(:temporary (:sc ,(sc-name (reg-spec-sc temp))
+		     `(:temporary (:sc ,(reg-spec-sc temp)
 				   :offset ,(reg-spec-offset temp)
-				   ,@(when (reg-spec-type temp)
-				       `(:type
-					 ,(reg-spec-type temp)))
-				   ,@(when (reg-spec-from temp)
-				       `(:from ,(reg-spec-from temp)))
-				   ,@(when (reg-spec-to temp)
-				       `(:to ,(reg-spec-to temp))))
+				   :from (:eval 1)
+				   :to (:eval 3))
 				  ,(reg-spec-name temp)))
 		 temps)
        (:temporary (:scs (interior-reg) :type interior
 			 :from (:eval 0) :to (:eval 1))
 		   ,lip)
-       (:temporary (:sc any-reg :offset lra-offset
-			:from (:eval 0) :to (:eval 1))
-		   ,return-pc)
+       (:temporary (:sc any-reg :offset lra-offset) ,return-pc)
        (:temporary (:scs (non-descriptor-reg) :type random
 			 :from (:eval 0) :to (:eval 1))
 		   ,ndescr)
+       ,@(let ((index -1))
+	   (mapcar #'(lambda (res)
+		       `(:temporary (:sc ,(reg-spec-sc res)
+				     :offset ,(reg-spec-offset res)
+				     :from (:eval 2)
+				     :to (:result ,(incf index))
+				     :target ,(reg-spec-name res))
+				    ,(reg-spec-temp res)))
+		   results))
        (:results ,@(mapcar #'arg-or-res-spec results))
-       (:ignore ,lip ,@(mapcar #'reg-spec-name orig-temps))
+       (:ignore ,lip ,@(mapcar #'reg-spec-name temps))
+       ,@options
        (:generator 247
-	 ,@(mapcar #'(lambda (arg)
-		       `(move ,(reg-spec-name (reg-spec-temp arg))
-			      ,(reg-spec-name arg)))
-		   args)
 	 (let ((,return-pc-label (gen-label)))
+	   ,@(mapcar #'(lambda (arg)
+			 `(move ,(reg-spec-temp arg)
+				,(reg-spec-name arg)))
+		     args)
 	   (inst compute-lra-from-code ,return-pc code-tn ,return-pc-label)
 	   (inst li ,ndescr (make-fixup ',name :assembly-routine))
 	   (inst j ,ndescr)
 	   (inst nop)
-	   (emit-return-pc ,return-pc-label))
-
-	 ,@(mapcar #'(lambda (res)
-		       `(move ,(reg-spec-name res)
-			      ,(reg-spec-name (reg-spec-temp res))))
-		   results)))))
-
-(defmacro define-assembly-routine ((name &rest vars) &rest code)
+	   (emit-return-pc ,return-pc-label)
+	   
+	   ,@(mapcar #'(lambda (res)
+			 `(move ,(reg-spec-name res)
+				,(reg-spec-temp res)))
+		     results))))))
+
+(defmacro define-assembly-routine ((name options &rest vars) &rest code)
   (let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
-    (allocate-regs regs)
     (if *do-assembly*
-	(emit-assemble name regs code)
-	(emit-vop name regs))))
+	(emit-assemble (if (atom name) name (car name)) regs code)
+	(emit-vop name options regs))))