Skip to content
Snippets Groups Projects
Commit fb645b12 authored by wlott's avatar wlott
Browse files

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.
parent 77429c57
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -21,7 +21,7 @@
define-emitter define-instruction define-instruction-macro define-emitter define-instruction define-instruction-macro
def-assembler-params 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 label label-p gen-label emit-label label-position
append-segment finalize-segment append-segment finalize-segment
segment-map-output release-segment)) segment-map-output release-segment))
...@@ -265,6 +265,21 @@ ...@@ -265,6 +265,21 @@
(clrhash *inst-ids*) (clrhash *inst-ids*)
(setf *next-inst-id* 0)) (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. ;;;; The scheduler itself.
...@@ -451,7 +466,7 @@ ...@@ -451,7 +466,7 @@
(setf (segment-run-scheduler segment) nil) (setf (segment-run-scheduler segment) nil)
(dolist (inst results) (dolist (inst results)
(if (eq inst :nop) (if (eq inst :nop)
(format t "*** NOP ***~%") (emit-nop segment)
(funcall (inst-emitter inst) segment))) (funcall (inst-emitter inst) segment)))
(setf (segment-run-scheduler segment) t)) (setf (segment-run-scheduler segment) t))
;; ;;
...@@ -1501,6 +1516,14 @@ ...@@ -1501,6 +1516,14 @@
vop-var vop-var
reconstructor)))))) 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. ;;; DEFINE-INSTRUCTION -- interface.
;;; ;;;
(defmacro define-instruction (name lambda-list &rest options) (defmacro define-instruction (name lambda-list &rest options)
...@@ -1514,7 +1537,8 @@ ...@@ -1514,7 +1537,8 @@
(reads nil) (reads nil)
(writes nil) (writes nil)
(delay nil) (delay nil)
(pinned nil)) (pinned nil)
(pdefs nil))
(dolist (option-spec options) (dolist (option-spec options)
(multiple-value-bind (multiple-value-bind
(option args) (option args)
...@@ -1531,12 +1555,12 @@ ...@@ -1531,12 +1555,12 @@
(:attributes (:attributes
(setf attributes (append attributes args))) (setf attributes (append attributes args)))
(:reads (:reads
(when reads (when (or reads (cdr args))
(error (error
"Can only specify one reads expression per instruction.")) "Can only specify one reads expression per instruction."))
(setf reads args)) (setf reads args))
(:writes (:writes
(when writes (when (or writes (cdr args))
(error (error
"Can only specify one writes expression per instruction.")) "Can only specify one writes expression per instruction."))
(setf writes args)) (setf writes args))
...@@ -1550,8 +1574,28 @@ ...@@ -1550,8 +1574,28 @@
(if vop-var (if vop-var
(error "Can only specify :vop-var once.") (error "Can only specify :vop-var once.")
(setf vop-var (car args)))) (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 (t
(error "Unknown option: ~S" (car option)))))) (error "Unknown option: ~S" option)))))
(setf pdefs (nreverse pdefs))
(multiple-value-bind (multiple-value-bind
(new-lambda-list segment-name vop-name arg-reconstructor) (new-lambda-list segment-name vop-name arg-reconstructor)
(grovel-lambda-list lambda-list vop-var) (grovel-lambda-list lambda-list vop-var)
...@@ -1581,8 +1625,10 @@ ...@@ -1581,8 +1625,10 @@
(instruction-attributes (instruction-attributes
,@attributes) ,@attributes)
(progn ,@delay)) (progn ,@delay))
(progn ,@reads) (canonicalize-locations
(progn ,@writes)) ,reads)
(canonicalize-locations
,writes))
(,flet-name ,segment-name)))))))) (,flet-name ,segment-name))))))))
`(progn `(progn
(defun ,defun-name ,new-lambda-list (defun ,defun-name ,new-lambda-list
...@@ -1599,7 +1645,11 @@ ...@@ -1599,7 +1645,11 @@
,@emitter)) ,@emitter))
(ext:undefined-value)) (ext:undefined-value))
(eval-when (compile load eval) (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. ;;; DEFINE-INSTRUCTION-MACRO -- interface.
;;; ;;;
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment