From fb645b127f6676d83723d5523a4b5b96d6eaf02f Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Fri, 24 Jul 1992 03:31:47 +0000
Subject: [PATCH] Added disassembler support.  Changed :reads and :writes stuff
 to call TN-LOCATION to convert TNs into locations.  Actually call EMIT-NOP
 instead of just printing a message that a nop needs to be inserted.

---
 compiler/new-assem.lisp | 70 +++++++++++++++++++++++++++++++++++------
 1 file changed, 60 insertions(+), 10 deletions(-)

diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp
index ea074aec8..9027a8a28 100644
--- a/compiler/new-assem.lisp
+++ b/compiler/new-assem.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.5 1992/07/12 19:35:19 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.6 1992/07/24 03:31:47 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -21,7 +21,7 @@
 	  define-emitter define-instruction define-instruction-macro
 	  def-assembler-params
 
-	  make-segment segment-name assemble align inst
+	  segment make-segment segment-name assemble align inst
 	  label label-p gen-label emit-label label-position
 	  append-segment finalize-segment
 	  segment-map-output release-segment))
@@ -265,6 +265,21 @@
   (clrhash *inst-ids*)
   (setf *next-inst-id* 0))
 
+
+;;;; Locations, and operations thereon.
+
+(defun canonicalize-locations (locations)
+  (let ((results nil))
+    (labels ((grovel (location)
+	       (typecase location
+		 (list (dolist (x location) (grovel x)))
+		 (c:tn (push (c:tn-location location) results))
+		 (number) ; blow off immediates
+		 (t (push location results)))))
+      (grovel locations))
+    results))
+
+
 
 ;;;; The scheduler itself.
 
@@ -451,7 +466,7 @@
     (setf (segment-run-scheduler segment) nil)
     (dolist (inst results)
       (if (eq inst :nop)
-	  (format t "*** NOP ***~%")
+	  (emit-nop segment)
 	  (funcall (inst-emitter inst) segment)))
     (setf (segment-run-scheduler segment) t))
   ;;
@@ -1501,6 +1516,14 @@
 		  vop-var
 		  reconstructor))))))
 
+(defun extract-nths (index glue list-of-lists-of-lists)
+  (mapcar #'(lambda (list-of-lists)
+	      (cons glue
+		    (mapcar #'(lambda (list)
+				(nth index list))
+			    list-of-lists)))
+	  list-of-lists-of-lists))
+
 ;;; DEFINE-INSTRUCTION -- interface.
 ;;; 
 (defmacro define-instruction (name lambda-list &rest options)
@@ -1514,7 +1537,8 @@
 	 (reads nil)
 	 (writes nil)
 	 (delay nil)
-	 (pinned nil))
+	 (pinned nil)
+	 (pdefs nil))
     (dolist (option-spec options)
       (multiple-value-bind
 	  (option args)
@@ -1531,12 +1555,12 @@
 	  (:attributes
 	   (setf attributes (append attributes args)))
 	  (:reads
-	   (when reads
+	   (when (or reads (cdr args))
 	     (error
 	      "Can only specify one reads expression per instruction."))
 	   (setf reads args))
 	  (:writes
-	   (when writes
+	   (when (or writes (cdr args))
 	     (error
 	      "Can only specify one writes expression per instruction."))
 	   (setf writes args))
@@ -1550,8 +1574,28 @@
 	   (if vop-var
 	       (error "Can only specify :vop-var once.")
 	       (setf vop-var (car args))))
+	  (:printer
+	   (push
+	    (eval
+	     `(list
+	       (multiple-value-list
+		,(disassem:gen-printer-def-forms-def-form name
+							  (cdr option-spec)))))
+	    pdefs))
+	  (:printer-list
+	   ;; same as :printer, but is evaled first, and is a list of printers
+	   (push
+	    (eval
+	     `(eval
+	       `(list ,@(mapcar #'(lambda (printer)
+				    `(multiple-value-list
+				      ,(disassem:gen-printer-def-forms-def-form
+					',name printer nil)))
+				,(cadr option-spec)))))
+	    pdefs))
 	  (t
-	   (error "Unknown option: ~S" (car option))))))
+	   (error "Unknown option: ~S" option)))))
+    (setf pdefs (nreverse pdefs))
     (multiple-value-bind
 	(new-lambda-list segment-name vop-name arg-reconstructor)
 	(grovel-lambda-list lambda-list vop-var)
@@ -1581,8 +1625,10 @@
 						 (instruction-attributes
 						  ,@attributes)
 						 (progn ,@delay))
-						(progn ,@reads)
-						(progn ,@writes))
+						(canonicalize-locations
+						 ,reads)
+						(canonicalize-locations
+						 ,writes))
 				    (,flet-name ,segment-name))))))))
       `(progn
 	 (defun ,defun-name ,new-lambda-list
@@ -1599,7 +1645,11 @@
 	       ,@emitter))
 	   (ext:undefined-value))
 	 (eval-when (compile load eval)
-	   (%define-instruction ,sym-name ',defun-name))))))
+	   (%define-instruction ,sym-name ',defun-name))
+	 ,@(extract-nths 1 'progn pdefs)
+	 (disassem:install-inst-flavors
+	  ',name
+	  (append ,@(extract-nths 0 'list pdefs)))))))
 
 ;;; DEFINE-INSTRUCTION-MACRO -- interface.
 ;;;
-- 
GitLab