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.
15 (defvar *do-assembly* nil
16 #!+sb-doc "If non-NIL, emit assembly code. If NIL, emit VOP templates.")
18 (defvar *lap-output-file* nil
19 #!+sb-doc "the FASL file currently being output to")
21 (defvar *entry-points* nil
22 #!+sb-doc "a list of (name . label) for every entry point")
24 (defvar *assembly-optimize* t
26 "Set this to NIL to inhibit assembly-level optimization. For compiler
27 debugging, rather than policy control.")
29 ;;; Note: You might think from the name that this would act like COMPILE-FILE,
30 ;;; but in fact it's arguably more like LOAD, even down to the return
31 ;;; convention. It LOADs a file, then writes out any assembly code created
33 (defun assemble-file (name
35 (output-file (make-pathname :defaults name
37 ;; FIXME: Consider nuking the filename defaulting logic here.
38 (let* ((*do-assembly* t)
39 (name (pathname name))
40 (*lap-output-file* (open-fasl-file (pathname output-file) name))
45 (*assembly-optimize* nil)
48 (let ((*features* (cons :sb-assembling *features*)))
50 (load (merge-pathnames name (make-pathname :type "lisp")))
51 (fasl-dump-cold-load-form `(in-package ,(package-name
54 (sb!assem:append-segment *code-segment* *elsewhere*)
55 (setf *elsewhere* nil)
56 (let ((length (sb!assem:finalize-segment *code-segment*)))
57 (dump-assembler-routines *code-segment*
63 (close-fasl-file *lap-output-file* (not won)))
67 (kind :temp :type (member :arg :temp :res))
68 (name nil :type symbol)
69 (temp nil :type symbol)
70 (scs nil :type (or list symbol))
72 (def!method print-object ((spec reg-spec) stream)
73 (print-unreadable-object (spec stream :type t)
75 ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S"
79 (reg-spec-offset spec))))
81 (defun reg-spec-sc (spec)
82 (if (atom (reg-spec-scs spec))
84 (car (reg-spec-scs spec))))
86 (defun parse-reg-spec (kind name sc offset)
87 (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
91 (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
94 (defun emit-assemble (name options regs code)
97 (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
102 `(,(reg-spec-name reg)
105 :sc (sc-or-lose ',(reg-spec-sc reg))
106 :offset ,(reg-spec-offset reg))))
109 (sb!assem:assemble (*code-segment* ',name)
111 (push (cons ',name ,name) *entry-points*)
113 ,@(generate-return-sequence
114 (or (cadr (assoc :return-style options)) :raw)))
115 (when sb!xc:*compile-print*
116 (format *error-output* "~S assembled~%" ',name)))))
118 (defun arg-or-res-spec (reg)
119 `(,(reg-spec-name reg)
120 :scs ,(if (atom (reg-spec-scs reg))
121 (list (reg-spec-scs reg))
123 ,@(unless (eq (reg-spec-kind reg) :res)
124 `(:target ,(reg-spec-temp reg)))))
126 (defun emit-vop (name options vars)
127 (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
128 (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
129 (results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
130 (return-style (or (cadr (assoc :return-style options)) :raw))
131 (cost (or (cadr (assoc :cost options)) 247))
132 (vop (make-symbol "VOP")))
133 (unless (member return-style '(:raw :full-call :none))
134 (error "unknown return-style for ~S: ~S" name return-style))
136 (call-sequence call-temps)
137 (generate-call-sequence name return-style vop)
138 `(define-vop ,(if (atom name) (list name) name)
139 (:args ,@(mapcar #'arg-or-res-spec args))
141 (mapcar #'(lambda (arg)
142 `(:temporary (:sc ,(reg-spec-sc arg)
143 :offset ,(reg-spec-offset arg)
144 :from (:argument ,(incf index))
146 ,(reg-spec-temp arg)))
148 ,@(mapcar #'(lambda (temp)
149 `(:temporary (:sc ,(reg-spec-sc temp)
150 :offset ,(reg-spec-offset temp)
153 ,(reg-spec-name temp)))
158 (mapcar #'(lambda (res)
159 `(:temporary (:sc ,(reg-spec-sc res)
160 :offset ,(reg-spec-offset res)
162 :to (:result ,(incf index))
163 :target ,(reg-spec-name res))
164 ,(reg-spec-temp res)))
166 (:results ,@(mapcar #'arg-or-res-spec results))
167 (:ignore ,@(mapcar #'reg-spec-name temps)
170 (remove :ignore call-temps
171 :test-not #'eq :key #'car))))
172 ,@(remove-if #'(lambda (x)
173 (member x '(:return-style :cost)))
177 ,@(mapcar #'(lambda (arg)
178 #!+(or hppa alpha) `(move ,(reg-spec-name arg)
179 ,(reg-spec-temp arg))
180 #!-(or hppa alpha) `(move ,(reg-spec-temp arg)
181 ,(reg-spec-name arg)))
184 ,@(mapcar #'(lambda (res)
185 #!+(or hppa alpha) `(move ,(reg-spec-temp res)
186 ,(reg-spec-name res))
187 #!-(or hppa alpha) `(move ,(reg-spec-name res)
188 ,(reg-spec-temp res)))
191 (def!macro define-assembly-routine (name&options vars &body code)
192 (multiple-value-bind (name options)
193 (if (atom name&options)
194 (values name&options nil)
195 (values (car name&options)
197 (let ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
199 (emit-assemble name options regs code)
200 (emit-vop name options regs)))))