1 ;;;; the extra code necessary to feed an entire file of assembly code
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
18 (defvar *do-assembly* nil
19 #!+sb-doc "If non-NIL, emit assembly code. If NIL, emit VOP templates.")
21 (defvar *lap-output-file* nil
22 #!+sb-doc "the FASL file currently being output to")
24 (defvar *entry-points* nil
25 #!+sb-doc "a list of (name . label) for every entry point")
27 (defvar *assembly-optimize* t
29 "Set this to NIL to inhibit assembly-level optimization. For compiler
30 debugging, rather than policy control.")
32 ;;; Note: You might think from the name that this would act like COMPILE-FILE,
33 ;;; but in fact it's arguably more like LOAD, even down to the return
34 ;;; convention. It LOADs a file, then writes out any assembly code created
36 (defun assemble-file (name
38 (output-file (make-pathname :defaults name
40 ;; FIXME: Consider nuking the filename defaulting logic here.
41 (let* ((*do-assembly* t)
42 (name (pathname name))
43 (*lap-output-file* (open-fasl-file (pathname output-file) name))
48 (*assembly-optimize* nil)
51 (let ((*features* (cons :sb-assembling *features*)))
53 (load (merge-pathnames name (make-pathname :type "lisp")))
54 (fasl-dump-cold-load-form `(in-package ,(package-name *package*))
56 (sb!assem:append-segment *code-segment* *elsewhere*)
57 (setf *elsewhere* nil)
58 (let ((length (sb!assem:finalize-segment *code-segment*)))
59 (dump-assembler-routines *code-segment*
65 (close-fasl-file *lap-output-file* (not won)))
69 (kind :temp :type (member :arg :temp :res))
70 (name nil :type symbol)
71 (temp nil :type symbol)
72 (scs nil :type (or list symbol))
74 (def!method print-object ((spec reg-spec) stream)
75 (print-unreadable-object (spec stream :type t)
77 ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S"
81 (reg-spec-offset spec))))
83 (defun reg-spec-sc (spec)
84 (if (atom (reg-spec-scs spec))
86 (car (reg-spec-scs spec))))
88 (defun parse-reg-spec (kind name sc offset)
89 (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
93 (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
96 (defun emit-assemble (name options regs code)
99 (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
104 `(,(reg-spec-name reg)
107 :sc (sc-or-lose ',(reg-spec-sc reg))
108 :offset ,(reg-spec-offset reg))))
111 (sb!assem:assemble (*code-segment* ',name)
113 (push (cons ',name ,name) *entry-points*)
115 ,@(generate-return-sequence
116 (or (cadr (assoc :return-style options)) :raw)))
117 (when sb!xc:*compile-print*
118 (format *error-output* "~S assembled~%" ',name)))))
120 (defun arg-or-res-spec (reg)
121 `(,(reg-spec-name reg)
122 :scs ,(if (atom (reg-spec-scs reg))
123 (list (reg-spec-scs reg))
125 ,@(unless (eq (reg-spec-kind reg) :res)
126 `(:target ,(reg-spec-temp reg)))))
128 (defun emit-vop (name options vars)
129 (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
130 (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
131 (results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
132 (return-style (or (cadr (assoc :return-style options)) :raw))
133 (cost (or (cadr (assoc :cost options)) 247))
134 (vop (make-symbol "VOP")))
135 (unless (member return-style '(:raw :full-call :none))
136 (error "unknown return-style for ~S: ~S" name return-style))
138 (call-sequence call-temps)
139 (generate-call-sequence name return-style vop)
140 `(define-vop ,(if (atom name) (list name) name)
141 (:args ,@(mapcar #'arg-or-res-spec args))
143 (mapcar #'(lambda (arg)
144 `(:temporary (:sc ,(reg-spec-sc arg)
145 :offset ,(reg-spec-offset arg)
146 :from (:argument ,(incf index))
148 ,(reg-spec-temp arg)))
150 ,@(mapcar #'(lambda (temp)
151 `(:temporary (:sc ,(reg-spec-sc temp)
152 :offset ,(reg-spec-offset temp)
155 ,(reg-spec-name temp)))
160 (mapcar #'(lambda (res)
161 `(:temporary (:sc ,(reg-spec-sc res)
162 :offset ,(reg-spec-offset res)
164 :to (:result ,(incf index))
165 :target ,(reg-spec-name res))
166 ,(reg-spec-temp res)))
168 (:results ,@(mapcar #'arg-or-res-spec results))
169 (:ignore ,@(mapcar #'reg-spec-name temps)
172 (remove :ignore call-temps
173 :test-not #'eq :key #'car))))
174 ,@(remove-if #'(lambda (x)
175 (member x '(:return-style :cost)))
179 ,@(mapcar #'(lambda (arg)
180 #!+(or hppa alpha) `(move ,(reg-spec-name arg)
181 ,(reg-spec-temp arg))
182 #!-(or hppa alpha) `(move ,(reg-spec-temp arg)
183 ,(reg-spec-name arg)))
186 ,@(mapcar #'(lambda (res)
187 #!+(or hppa alpha) `(move ,(reg-spec-temp res)
188 ,(reg-spec-name res))
189 #!-(or hppa alpha) `(move ,(reg-spec-name res)
190 ,(reg-spec-temp res)))
193 (def!macro define-assembly-routine (name&options vars &body code)
194 (multiple-value-bind (name options)
195 (if (atom name&options)
196 (values name&options nil)
197 (values (car name&options)
199 (let ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
201 (emit-assemble name options regs code)
202 (emit-vop name options regs)))))