assemfile.lisp 6.66 KB
Newer Older
wlott's avatar
wlott committed
1
;;; -*- Package: C -*-
wlott's avatar
wlott committed
2 3
;;;
;;; **********************************************************************
wlott's avatar
wlott committed
4 5 6 7
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/assembly/assemfile.lisp $")
wlott's avatar
wlott committed
9
;;;
wlott's avatar
wlott committed
10
;;; **********************************************************************
wlott's avatar
wlott committed
11 12 13 14 15 16
;;;
;;; This file contains the extra code necessary to feed an entire file of
;;; assembly code to the assembler.
;;;
(in-package "C")

wlott's avatar
wlott committed
17 18
(export '(define-assembly-routine))

wlott's avatar
wlott committed
19 20 21 22 23 24 25 26 27 28

(defvar *do-assembly* nil
  "If non-NIL, emit assembly code.  If NIL, emit VOP templates.")

(defvar *lap-output-file* nil
  "The FASL file currently being output to.")

(defvar *assembler-routines* nil
  "A List of (name . label) for every entry point.")

29 30 31
(defun assemble-file (name &key
			   (output-file
			    (make-pathname :defaults name
32
					   :type "assem"))
33
			   trace-file)
wlott's avatar
wlott committed
34 35 36 37
  (let* ((*do-assembly* t)
	 (name (pathname name))
	 (*lap-output-file* (open-fasl-file (pathname output-file) name))
	 (*assembler-routines* nil)
wlott's avatar
wlott committed
38
	 (*load-verbose* nil)
39 40 41
	 (won nil)
	 (*code-segment* nil)
	 (*elsewhere* nil)
42 43
	 (*assembly-optimize* nil)
	 (*compiler-trace-output* nil)
44 45
	 (*fixups* nil)
	 (*coalesce-constants* t))
wlott's avatar
wlott committed
46
    (unwind-protect
47
	(let ((*features* (cons :assembler (backend-features *backend*))))
wlott's avatar
wlott committed
48
	  (when trace-file
49 50 51 52 53 54 55
	    (setf *compiler-trace-output*
		  (open (if (eq trace-file t)
			    (make-pathname :defaults name
					   :type "trace")
			    trace-file)
			:direction :output
			:if-exists :supersede)))
wlott's avatar
wlott committed
56
	  (init-assembler)
57
	  (load (merge-pathnames name (make-pathname :type "lisp")))
58 59
	  (fasl-dump-cold-load-form `(in-package ,(package-name *package*))
				    *lap-output-file*)
wlott's avatar
wlott committed
60 61 62
	  (new-assem:append-segment *code-segment* *elsewhere*)
	  (setf *elsewhere* nil)
	  (let ((length (new-assem:finalize-segment *code-segment*)))
wlott's avatar
wlott committed
63 64
	    (dump-assembler-routines *code-segment*
				     length
65
				     *fixups*
66
				     *assembler-routines*
wlott's avatar
wlott committed
67
				     *lap-output-file*))
wlott's avatar
wlott committed
68
	  (setq won t))
wlott's avatar
wlott committed
69 70 71
      (new-assem:release-segment *code-segment*)
      (when *elsewhere*
	(new-assem:release-segment *elsewhere*))
72 73
      (when *compiler-trace-output*
	(close *compiler-trace-output*))
wlott's avatar
wlott committed
74 75 76 77 78 79 80
      (close-fasl-file *lap-output-file* (not won)))
    won))



(defstruct (reg-spec
	    (:print-function %print-reg-spec))
81
  (kind :temp :type (member :arg :temp :res))
82 83
  (name nil :type symbol)
  (temp nil :type symbol)
84
  (scs nil :type (or list symbol))
85
  (offset nil))
wlott's avatar
wlott committed
86 87 88

(defun %print-reg-spec (spec stream depth)
  (declare (ignore depth))
89
  (format stream
90
	  "#<reg ~S ~S scs=~S offset=~S>"
91 92
	  (reg-spec-kind spec)
	  (reg-spec-name spec)
93
	  (reg-spec-scs spec)
94
	  (reg-spec-offset spec)))
wlott's avatar
wlott committed
95

96 97 98 99
(defun reg-spec-sc (spec)
  (if (atom (reg-spec-scs spec))
      (reg-spec-scs spec)
      (car (reg-spec-scs spec))))
wlott's avatar
wlott committed
100

101
(defun parse-reg-spec (kind name sc offset)
102
  (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
103 104 105 106 107
    (ecase kind
      (:temp)
      ((:arg :res)
       (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
    reg))
wlott's avatar
wlott committed
108 109


110
(defun emit-assemble (name options regs code)
wlott's avatar
wlott committed
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
  (collect ((decls))
    (loop
      (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
	  (decls (pop code))
	  (return)))
    `(let (,@(mapcar
	      #'(lambda (reg)
		  `(,(reg-spec-name reg)
		    (make-random-tn
		     :kind :normal
		     :sc (sc-or-lose ',(reg-spec-sc reg))
		     :offset ,(reg-spec-offset reg))))
	      regs))
       ,@(decls)
       (new-assem:assemble (*code-segment* ',name)
	 ,name
	 (push (cons ',name ,name) *assembler-routines*)
	 ,@code
	 ,@(generate-return-sequence
	    (or (cadr (assoc :return-style options)) :raw)))
       (when *compile-print*
132
	 (format *error-output* "; ~S assembled~%" ',name)))))
wlott's avatar
wlott committed
133 134 135

(defun arg-or-res-spec (reg)
  `(,(reg-spec-name reg)
136 137 138
    :scs ,(if (atom (reg-spec-scs reg))
	      (list (reg-spec-scs reg))
	      (reg-spec-scs reg))
wlott's avatar
wlott committed
139
    ,@(unless (eq (reg-spec-kind reg) :res)
140
	`(:target ,(reg-spec-temp reg)))))
wlott's avatar
wlott committed
141

142
(defun emit-vop (name options vars)
wlott's avatar
wlott committed
143
  (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
144
	 (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
wlott's avatar
wlott committed
145
	 (results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
146 147
	 (return-style (or (cadr (assoc :return-style options)) :raw))
	 (cost (or (cadr (assoc :cost options)) 247))
148
	 (vop (make-symbol "VOP")))
149 150
    (unless (member return-style '(:raw :full-call :none))
      (error "Unknown return-style for ~S: ~S" name return-style))
151 152
    (multiple-value-bind
	(call-sequence call-temps)
153 154
	(let ((*backend* *target-backend*))
	  (generate-call-sequence name return-style vop))
155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183
      `(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 ,(reg-spec-sc temp)
					 :offset ,(reg-spec-offset temp)
					 :from (:eval 1)
					 :to (:eval 3))
				    ,(reg-spec-name temp)))
		   temps)
	 ,@call-temps
	 (:vop-var ,vop)
	 ,@(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))
wlott's avatar
wlott committed
184 185 186 187 188
	 (:ignore ,@(mapcar #'reg-spec-name temps)
		  ,@(apply #'append
			   (mapcar #'cdr
				   (remove :ignore call-temps
					   :test-not #'eq :key #'car))))
189 190 191 192 193 194
	 ,@(remove-if #'(lambda (x)
			  (member x '(:return-style :cost)))
		      options
		      :key #'car)
	 (:generator ,cost
	   ,@(mapcar #'(lambda (arg)
195 196
			 (if (or (target-featurep :hppa)
				 (target-featurep :alpha))
197 198 199 200
			     `(move ,(reg-spec-name arg)
				    ,(reg-spec-temp arg))
			     `(move ,(reg-spec-temp arg)
				    ,(reg-spec-name arg))))
201 202 203
		     args)
	   ,@call-sequence
	   ,@(mapcar #'(lambda (res)
204 205
			 (if (or (target-featurep :hppa)
				 (target-featurep :alpha))
206 207 208 209
			     `(move ,(reg-spec-temp res)
				    ,(reg-spec-name res))
			     `(move ,(reg-spec-name res)
				    ,(reg-spec-temp res))))
210
		     results))))))
211

212 213 214 215 216 217 218 219 220 221
(defmacro define-assembly-routine (name&options vars &rest code)
  (multiple-value-bind (name options)
		       (if (atom name&options)
			   (values name&options nil)
			   (values (car name&options)
				   (cdr name&options)))
    (let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
      (if *do-assembly*
	  (emit-assemble name options regs code)
	  (emit-vop name options regs)))))