0.pre8.94:
[sbcl.git] / src / assembly / assemfile.lisp
1 ;;;; the extra code necessary to feed an entire file of assembly code
2 ;;;; to the assembler
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
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.
12
13 (in-package "SB!C")
14 \f
15 ;;; If non-NIL, emit assembly code. If NIL, emit VOP templates.
16 (defvar *emit-assembly-code-not-vops-p* nil)
17
18 ;;; a list of (NAME . LABEL) for every entry point
19 (defvar *entry-points* nil)
20
21 ;;; Set this to NIL to inhibit assembly-level optimization. (For
22 ;;; compiler debugging, rather than policy control.)
23 (defvar *assembly-optimize* t)
24
25 ;;; Note: You might think from the name that this would act like
26 ;;; COMPILE-FILE, but in fact it's arguably more like LOAD, even down
27 ;;; to the return convention. It LOADs a file, then writes out any
28 ;;; assembly code created by the process.
29 (defun assemble-file (name
30                       &key
31                       (output-file (make-pathname :defaults name
32                                                   :type "assem")))
33   ;; FIXME: Consider nuking the filename defaulting logic here.
34   (let* ((*emit-assembly-code-not-vops-p* t)
35          (name (pathname name))
36          ;; the fasl file currently being output to
37          (lap-fasl-output (open-fasl-output (pathname output-file) name))
38          (*entry-points* nil)
39          (won nil)
40          (*code-segment* nil)
41          (*elsewhere* nil)
42          (*assembly-optimize* nil)
43          (*fixups* nil))
44     (unwind-protect
45         (let ((*features* (cons :sb-assembling *features*)))
46           (init-assembler)
47           (load (merge-pathnames name (make-pathname :type "lisp")))
48           (fasl-dump-cold-load-form `(in-package ,(package-name
49                                                    (sane-package)))
50                                     lap-fasl-output)
51           (sb!assem:append-segment *code-segment* *elsewhere*)
52           (setf *elsewhere* nil)
53           (let ((length (sb!assem:finalize-segment *code-segment*)))
54             (dump-assembler-routines *code-segment*
55                                      length
56                                      *fixups*
57                                      *entry-points*
58                                      lap-fasl-output))
59           (setq won t))
60       (close-fasl-output lap-fasl-output (not won)))
61     won))
62
63 (defstruct (reg-spec (:copier nil))
64   (kind :temp :type (member :arg :temp :res))
65   (name nil :type symbol)
66   (temp nil :type symbol)
67   (scs nil :type (or list symbol))
68   (offset nil))
69 (def!method print-object ((spec reg-spec) stream)
70   (print-unreadable-object (spec stream :type t)
71     (format stream
72             ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S"
73             (reg-spec-kind spec)
74             (reg-spec-name spec)
75             (reg-spec-scs spec)
76             (reg-spec-offset spec))))
77
78 (defun reg-spec-sc (spec)
79   (if (atom (reg-spec-scs spec))
80       (reg-spec-scs spec)
81       (car (reg-spec-scs spec))))
82
83 (defun parse-reg-spec (kind name sc offset)
84   (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
85     (ecase kind
86       (:temp)
87       ((:arg :res)
88        (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
89     reg))
90
91 (defun emit-assemble (name options regs code)
92   (collect ((decls))
93     (loop
94       (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
95           (decls (pop code))
96           (return)))
97     `(let ,(mapcar (lambda (reg)
98                      `(,(reg-spec-name reg)
99                        (make-random-tn
100                         :kind :normal
101                         :sc (sc-or-lose ',(reg-spec-sc reg))
102                         :offset ,(reg-spec-offset reg))))
103                    regs)
104        ,@(decls)
105        (sb!assem:assemble (*code-segment* ',name)
106          ,name
107          (push (cons ',name ,name) *entry-points*)
108          ,@code
109          ,@(generate-return-sequence
110             (or (cadr (assoc :return-style options)) :raw)))
111        (when sb!xc:*compile-print*
112          (format *error-output* "~S assembled~%" ',name)))))
113
114 (defun arg-or-res-spec (reg)
115   `(,(reg-spec-name reg)
116     :scs ,(if (atom (reg-spec-scs reg))
117               (list (reg-spec-scs reg))
118               (reg-spec-scs reg))
119     ,@(unless (eq (reg-spec-kind reg) :res)
120         `(:target ,(reg-spec-temp reg)))))
121
122 (defun emit-vop (name options vars)
123   (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
124          (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
125          (results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
126          (return-style (or (cadr (assoc :return-style options)) :raw))
127          (cost (or (cadr (assoc :cost options)) 247))
128          (vop (make-symbol "VOP")))
129     (unless (member return-style '(:raw :full-call :none))
130       (error "unknown return-style for ~S: ~S" name return-style))
131     (multiple-value-bind
132         (call-sequence call-temps)
133         (generate-call-sequence name return-style vop)
134       `(define-vop ,(if (atom name) (list name) name)
135          (:args ,@(mapcar #'arg-or-res-spec args))
136          ,@(let ((index -1))
137              (mapcar (lambda (arg)
138                        `(:temporary (:sc ,(reg-spec-sc arg)
139                                      :offset ,(reg-spec-offset arg)
140                                      :from (:argument ,(incf index))
141                                      :to (:eval 2))
142                                     ,(reg-spec-temp arg)))
143                      args))
144          ,@(mapcar (lambda (temp)
145                      `(:temporary (:sc ,(reg-spec-sc temp)
146                                    :offset ,(reg-spec-offset temp)
147                                    :from (:eval 1)
148                                    :to (:eval 3))
149                                   ,(reg-spec-name temp)))
150                    temps)
151          ,@call-temps
152          (:vop-var ,vop)
153          ,@(let ((index -1))
154              (mapcar (lambda (res)
155                        `(:temporary (:sc ,(reg-spec-sc res)
156                                      :offset ,(reg-spec-offset res)
157                                      :from (:eval 2)
158                                      :to (:result ,(incf index))
159                                      :target ,(reg-spec-name res))
160                                     ,(reg-spec-temp res)))
161                      results))
162          (:results ,@(mapcar #'arg-or-res-spec results))
163          (:ignore ,@(mapcar #'reg-spec-name temps)
164                   ,@(apply #'append
165                            (mapcar #'cdr
166                                    (remove :ignore call-temps
167                                            :test-not #'eq :key #'car))))
168          ,@(remove-if (lambda (x)
169                         (member x '(:return-style :cost)))
170                       options
171                       :key #'car)
172          (:generator ,cost
173            ,@(mapcar (lambda (arg)
174                        #!+(or hppa alpha) `(move ,(reg-spec-name arg)
175                                                  ,(reg-spec-temp arg))
176                        #!-(or hppa alpha) `(move ,(reg-spec-temp arg)
177                                                  ,(reg-spec-name arg)))
178                      args)
179            ,@call-sequence
180            ,@(mapcar (lambda (res)
181                        #!+(or hppa alpha) `(move ,(reg-spec-temp res)
182                                                  ,(reg-spec-name res))
183                        #!-(or hppa alpha) `(move ,(reg-spec-name res)
184                                                  ,(reg-spec-temp res)))
185                      results))))))
186
187 (def!macro define-assembly-routine (name&options vars &body code)
188   (multiple-value-bind (name options)
189       (if (atom name&options)
190           (values name&options nil)
191         (values (car name&options)
192                 (cdr name&options)))
193     (let ((regs (mapcar (lambda (var) (apply #'parse-reg-spec var)) vars)))
194       (if *emit-assembly-code-not-vops-p*
195           (emit-assemble name options regs code)
196           (emit-vop name options regs)))))