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 ;;; If non-NIL, emit assembly code. If NIL, emit VOP templates.
16 (defvar *emit-assembly-code-not-vops-p
* nil
)
18 ;;; a list of (NAME LABEL OFFSET) for every entry point
19 (defvar *entry-points
* nil
)
21 ;;; Note: You might think from the name that this would act like
22 ;;; COMPILE-FILE, but in fact it's arguably more like LOAD, even down
23 ;;; to the return convention. It LOADs a file, then writes out any
24 ;;; assembly code created by the process.
25 (defun assemble-file (name
27 (output-file (make-pathname :defaults name
29 (when sb-cold
::*compile-for-effect-only
*
30 (return-from assemble-file t
))
31 ;; FIXME: Consider nuking the filename defaulting logic here.
32 (let* ((*emit-assembly-code-not-vops-p
* t
)
33 (name (pathname name
))
34 ;; the fasl file currently being output to
35 (lap-fasl-output (open-fasl-output (pathname output-file
) name
))
40 (*assembly-optimize
* nil
)
42 #!+inline-constants
(*unboxed-constants
* nil
))
44 (let ((*features
* (cons :sb-assembling
*features
*)))
46 (load (merge-pathnames name
(make-pathname :type
"lisp")))
47 (sb!assem
:append-segment
*code-segment
* *elsewhere
*)
48 (setf *elsewhere
* nil
)
50 (emit-inline-constants)
51 (let ((length (sb!assem
:finalize-segment
*code-segment
*)))
52 (dump-assembler-routines *code-segment
*
58 (close-fasl-output lap-fasl-output
(not won
)))
61 (defstruct (reg-spec (:copier nil
))
62 (kind :temp
:type
(member :arg
:temp
:res
))
63 (name nil
:type symbol
)
64 (temp nil
:type symbol
)
65 (scs nil
:type
(or list symbol
))
67 (defmethod print-object ((spec reg-spec
) stream
)
68 (print-unreadable-object (spec stream
:type t
)
70 ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S"
74 (reg-spec-offset spec
))))
76 (defun reg-spec-sc (spec)
77 (if (atom (reg-spec-scs spec
))
79 (car (reg-spec-scs spec
))))
81 (defun parse-reg-spec (kind name sc offset
)
82 (let ((reg (make-reg-spec :kind kind
:name name
:scs sc
:offset offset
)))
86 (setf (reg-spec-temp reg
) (make-symbol (symbol-name name
)))))
89 (defun expand-one-export-spec (export)
91 `(list ',export
,export
0)
93 (name (operator base-label offset
))
95 ;; KLUDGE: Presume that all compound export specs are of the
96 ;; form (NAME (OPERATOR BASE-LABEL OFFSET)), where OPERATOR is
97 ;; + or -, BASE-LABEL is a LABEL in the present scope, and
98 ;; OFFSET evaluates to an integer. Ideally, we should be
99 ;; smarter about this.
100 `(list ',name
,base-label
(,operator
,offset
)))))
102 (defun expand-export-option (exports)
104 for export in exports
105 collect
`(push ,(expand-one-export-spec export
) *entry-points
*)))
107 (defun expand-align-option (align)
109 `((emit-alignment ,align
))))
111 (defun emit-assemble (name options regs code
)
114 (if (and (consp code
) (consp (car code
)) (eq (caar code
) 'declare
))
117 `(let ,(mapcar (lambda (reg)
118 `(,(reg-spec-name reg
)
121 :sc
(sc-or-lose ',(reg-spec-sc reg
))
122 :offset
,(reg-spec-offset reg
))))
125 (sb!assem
:assemble
(*code-segment
* ',name
)
126 ,@(expand-align-option (cadr (assoc :align options
)))
128 (push (list ',name
,name
0) *entry-points
*)
129 ,@(expand-export-option (cdr (assoc :export options
)))
131 ,@(generate-return-sequence
132 (or (cadr (assoc :return-style options
)) :raw
))
133 (emit-alignment sb
!vm
:n-lowtag-bits
))
134 (when *compile-print
*
135 (format *error-output
* "~S assembled~%" ',name
)))))
137 (defun arg-or-res-spec (reg)
138 `(,(reg-spec-name reg
)
139 :scs
,(if (atom (reg-spec-scs reg
))
140 (list (reg-spec-scs reg
))
142 ,@(unless (eq (reg-spec-kind reg
) :res
)
143 `(:target
,(reg-spec-temp reg
)))))
145 (defun emit-assemble-vop (name options vars
)
146 (let* ((args (remove :arg vars
:key
#'reg-spec-kind
:test
#'neq
))
147 (temps (remove :temp vars
:key
#'reg-spec-kind
:test
#'neq
))
148 (results (remove :res vars
:key
#'reg-spec-kind
:test
#'neq
))
149 (return-style (or (cadr (assoc :return-style options
)) :raw
))
150 (cost (or (cadr (assoc :cost options
)) 247))
151 (vop (make-symbol "VOP")))
152 (unless (member return-style
'(:raw
:full-call
:none
))
153 (error "unknown return-style for ~S: ~S" name return-style
))
154 (multiple-value-bind (call-sequence call-temps
)
155 (generate-call-sequence name return-style vop options
)
156 `(define-vop ,(if (atom name
) (list name
) name
)
157 (:args
,@(mapcar #'arg-or-res-spec args
))
159 (mapcar (lambda (arg)
160 `(:temporary
(:sc
,(reg-spec-sc arg
)
161 :offset
,(reg-spec-offset arg
)
162 :from
(:argument
,(incf index
))
164 ,(reg-spec-temp arg
)))
166 ,@(mapcar (lambda (temp)
167 `(:temporary
(:sc
,(reg-spec-sc temp
)
168 :offset
,(reg-spec-offset temp
)
171 ,(reg-spec-name temp
)))
175 (mapcar (lambda (res)
176 `(:temporary
(:sc
,(reg-spec-sc res
)
177 :offset
,(reg-spec-offset res
)
179 :to
(:result
,(incf index
))
180 :target
,(reg-spec-name res
))
181 ,(reg-spec-temp res
)))
183 (:results
,@(mapcar #'arg-or-res-spec results
))
184 ;; This formerly unioned in the contents of an :ignore clause from
185 ;; the value of the 'call-temps' variable, for no good reason afaict.
186 (:ignore
,@(sort (set-difference (mapcar #'reg-spec-name temps
)
187 (cdr (assoc :call-temps options
)))
190 ;; This too is a tad sleazy - because of how VOP parsing works,
191 ;; any :SAVE-P specified in options supersedes one from call-temps.
192 ;; It would be wiser to signal an error about duplicate options.
193 ,@(remove-if (lambda (x)
194 (member x
'(:return-style
:cost
:call-temps
)))
198 ,@(mapcar (lambda (arg)
199 #!+(or hppa alpha
) `(move ,(reg-spec-name arg
)
200 ,(reg-spec-temp arg
))
201 #!-
(or hppa alpha
) `(move ,(reg-spec-temp arg
)
202 ,(reg-spec-name arg
)))
205 ,@(mapcar (lambda (res)
206 #!+(or hppa alpha
) `(move ,(reg-spec-temp res
)
207 ,(reg-spec-name res
))
208 #!-
(or hppa alpha
) `(move ,(reg-spec-name res
)
209 ,(reg-spec-temp res
)))