X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fassembly%2Fassemfile.lisp;h=591acfb2a54b2105bb14cbe541b792a4a9e61634;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=ac8ab34479ecb4bb87aa84a93c2e1c2deb2d1aa3;hpb=79cc569a97e444389350ea3f5b1017374fe16bec;p=sbcl.git diff --git a/src/assembly/assemfile.lisp b/src/assembly/assemfile.lisp index ac8ab34..591acfb 100644 --- a/src/assembly/assemfile.lisp +++ b/src/assembly/assemfile.lisp @@ -27,36 +27,36 @@ ;;; 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"))) + &key + (output-file (make-pathname :defaults name + :type "assem"))) ;; FIXME: Consider nuking the filename defaulting logic here. (let* ((*emit-assembly-code-not-vops-p* t) - (name (pathname 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) - (*elsewhere* nil) - (*assembly-optimize* nil) - (*fixup-notes* nil)) + (name (pathname 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) + (*elsewhere* nil) + (*assembly-optimize* nil) + (*fixup-notes* nil)) (unwind-protect - (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 - (sane-package))) - lap-fasl-output) - (sb!assem:append-segment *code-segment* *elsewhere*) - (setf *elsewhere* nil) - (let ((length (sb!assem:finalize-segment *code-segment*))) - (dump-assembler-routines *code-segment* - length - *fixup-notes* - *entry-points* - lap-fasl-output)) - (setq won t)) + (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 + (sane-package))) + lap-fasl-output) + (sb!assem:append-segment *code-segment* *elsewhere*) + (setf *elsewhere* nil) + (let ((length (sb!assem:finalize-segment *code-segment*))) + (dump-assembler-routines *code-segment* + length + *fixup-notes* + *entry-points* + lap-fasl-output)) + (setq won t)) (close-fasl-output lap-fasl-output (not won))) won)) @@ -69,11 +69,11 @@ (def!method print-object ((spec reg-spec) stream) (print-unreadable-object (spec stream :type t) (format stream - ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S" - (reg-spec-kind spec) - (reg-spec-name spec) - (reg-spec-scs spec) - (reg-spec-offset spec)))) + ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S" + (reg-spec-kind spec) + (reg-spec-name spec) + (reg-spec-scs spec) + (reg-spec-offset spec)))) (defun reg-spec-sc (spec) (if (atom (reg-spec-scs spec)) @@ -92,105 +92,105 @@ (collect ((decls)) (loop (if (and (consp code) (consp (car code)) (eq (caar code) 'declare)) - (decls (pop code)) - (return))) + (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) + `(,(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 - (push (cons ',name ,name) *entry-points*) - ,@code - ,@(generate-return-sequence - (or (cadr (assoc :return-style options)) :raw))) + ,name + (push (cons ',name ,name) *entry-points*) + ,@code + ,@(generate-return-sequence + (or (cadr (assoc :return-style options)) :raw))) (when sb!xc:*compile-print* - (format *error-output* "~S assembled~%" ',name))))) + (format *error-output* "~S assembled~%" ',name))))) (defun arg-or-res-spec (reg) `(,(reg-spec-name reg) :scs ,(if (atom (reg-spec-scs reg)) - (list (reg-spec-scs reg)) - (reg-spec-scs reg)) + (list (reg-spec-scs reg)) + (reg-spec-scs reg)) ,@(unless (eq (reg-spec-kind reg) :res) - `(:target ,(reg-spec-temp reg))))) + `(:target ,(reg-spec-temp reg))))) (defun emit-vop (name options vars) (let* ((args (remove :arg vars :key #'reg-spec-kind :test #'neq)) - (temps (remove :temp vars :key #'reg-spec-kind :test #'neq)) - (results (remove :res vars :key #'reg-spec-kind :test #'neq)) - (return-style (or (cadr (assoc :return-style options)) :raw)) - (cost (or (cadr (assoc :cost options)) 247)) - (vop (make-symbol "VOP"))) + (temps (remove :temp vars :key #'reg-spec-kind :test #'neq)) + (results (remove :res vars :key #'reg-spec-kind :test #'neq)) + (return-style (or (cadr (assoc :return-style options)) :raw)) + (cost (or (cadr (assoc :cost options)) 247)) + (vop (make-symbol "VOP"))) (unless (member return-style '(:raw :full-call :none)) (error "unknown return-style for ~S: ~S" name return-style)) (multiple-value-bind - (call-sequence call-temps) - (generate-call-sequence name return-style vop) + (call-sequence call-temps) + (generate-call-sequence name return-style vop) `(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))) - 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))) - 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))) - results)) - (:results ,@(mapcar #'arg-or-res-spec results)) - (:ignore ,@(mapcar #'reg-spec-name temps) - ,@(apply #'append - (mapcar #'cdr - (remove :ignore call-temps - :test #'neq :key #'car)))) - ,@(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))) - 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))) - results)))))) + (: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))) + 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))) + 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))) + results)) + (:results ,@(mapcar #'arg-or-res-spec results)) + (:ignore ,@(mapcar #'reg-spec-name temps) + ,@(apply #'append + (mapcar #'cdr + (remove :ignore call-temps + :test #'neq :key #'car)))) + ,@(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))) + 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))) + results)))))) (def!macro define-assembly-routine (name&options vars &body code) (multiple-value-bind (name options) (if (atom name&options) - (values name&options nil) - (values (car name&options) - (cdr name&options))) + (values name&options nil) + (values (car name&options) + (cdr name&options))) (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))))) + (emit-assemble name options regs code) + (emit-vop name options regs)))))