;;; 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))
(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))
(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)))))
projects / sbcl.git / blobdiff