X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fassembly%2Fassemfile.lisp;h=dd2cabfa084576df84cdfecdd9c4448f6e679384;hb=41ed816c7915806abca6b09ecd2136458f27adcc;hp=d17a5a3ca4549390dc0e60cb04ae2a46ceb40bed;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/assembly/assemfile.lisp b/src/assembly/assemfile.lisp index d17a5a3..dd2cabf 100644 --- a/src/assembly/assemfile.lisp +++ b/src/assembly/assemfile.lisp @@ -11,36 +11,30 @@ ;;;; files for more information. (in-package "SB!C") - -(file-comment - "$Header$") -(defvar *do-assembly* nil - #!+sb-doc "If non-NIL, emit assembly code. If NIL, emit VOP templates.") - -(defvar *lap-output-file* nil - #!+sb-doc "the FASL file currently being output to") +;;; If non-NIL, emit assembly code. If NIL, emit VOP templates. +(defvar *emit-assembly-code-not-vops-p* nil) -(defvar *entry-points* nil - #!+sb-doc "a list of (name . label) for every entry point") +;;; a list of (NAME . LABEL) for every entry point +(defvar *entry-points* nil) -(defvar *assembly-optimize* t - #!+sb-doc - "Set this to NIL to inhibit assembly-level optimization. For compiler - debugging, rather than policy control.") +;;; Set this to NIL to inhibit assembly-level optimization. (For +;;; compiler debugging, rather than policy control.) +(defvar *assembly-optimize* t) -;;; Note: You might think from the name that this would act like COMPILE-FILE, -;;; but in fact it's arguably more like LOAD, even down to the return -;;; convention. It LOADs a file, then writes out any assembly code created -;;; by the process. +;;; Note: You might think from the name that this would act like +;;; COMPILE-FILE, but in fact it's arguably more like LOAD, even down +;;; to the return convention. It LOADs a file, then writes out any +;;; assembly code created by the process. (defun assemble-file (name &key (output-file (make-pathname :defaults name :type "assem"))) ;; FIXME: Consider nuking the filename defaulting logic here. - (let* ((*do-assembly* t) + (let* ((*emit-assembly-code-not-vops-p* t) (name (pathname name)) - (*lap-output-file* (open-fasl-file (pathname output-file) name)) + ;; the fasl file currently being output to + (lap-fasl-output (open-fasl-output (pathname output-file) name)) (*entry-points* nil) (won nil) (*code-segment* nil) @@ -51,8 +45,9 @@ (let ((*features* (cons :sb-assembling *features*))) (init-assembler) (load (merge-pathnames name (make-pathname :type "lisp"))) - (fasl-dump-cold-load-form `(in-package ,(package-name *package*)) - *lap-output-file*) + (fasl-dump-cold-load-form `(in-package ,(package-name + (sane-package))) + lap-fasl-output) (sb!assem:append-segment *code-segment* *elsewhere*) (setf *elsewhere* nil) (let ((length (sb!assem:finalize-segment *code-segment*))) @@ -60,12 +55,12 @@ length *fixups* *entry-points* - *lap-output-file*)) + lap-fasl-output)) (setq won t)) - (close-fasl-file *lap-output-file* (not won))) + (close-fasl-output lap-fasl-output (not won))) won)) -(defstruct reg-spec +(defstruct (reg-spec (:copier nil)) (kind :temp :type (member :arg :temp :res)) (name nil :type symbol) (temp nil :type symbol) @@ -99,14 +94,13 @@ (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)) + `(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) (sb!assem:assemble (*code-segment* ',name) ,name @@ -140,30 +134,30 @@ `(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))) + (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))) + ,@(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))) + (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)) (:ignore ,@(mapcar #'reg-spec-name temps) @@ -171,23 +165,23 @@ (mapcar #'cdr (remove :ignore call-temps :test-not #'eq :key #'car)))) - ,@(remove-if #'(lambda (x) - (member x '(:return-style :cost))) + ,@(remove-if (lambda (x) + (member x '(:return-style :cost))) options :key #'car) (:generator ,cost - ,@(mapcar #'(lambda (arg) - #!+(or hppa alpha) `(move ,(reg-spec-name arg) - ,(reg-spec-temp arg)) - #!-(or hppa alpha) `(move ,(reg-spec-temp arg) - ,(reg-spec-name arg))) + ,@(mapcar (lambda (arg) + #!+(or hppa alpha) `(move ,(reg-spec-name arg) + ,(reg-spec-temp arg)) + #!-(or hppa alpha) `(move ,(reg-spec-temp arg) + ,(reg-spec-name arg))) args) ,@call-sequence - ,@(mapcar #'(lambda (res) - #!+(or hppa alpha) `(move ,(reg-spec-temp res) - ,(reg-spec-name res)) - #!-(or hppa alpha) `(move ,(reg-spec-name res) - ,(reg-spec-temp res))) + ,@(mapcar (lambda (res) + #!+(or hppa alpha) `(move ,(reg-spec-temp res) + ,(reg-spec-name res)) + #!-(or hppa alpha) `(move ,(reg-spec-name res) + ,(reg-spec-temp res))) results)))))) (def!macro define-assembly-routine (name&options vars &body code) @@ -196,7 +190,7 @@ (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* + (let ((regs (mapcar (lambda (var) (apply #'parse-reg-spec var)) vars))) + (if *emit-assembly-code-not-vops-p* (emit-assemble name options regs code) (emit-vop name options regs)))))