0.7.6.20:

[sbcl.git] / src / assembly / assemfile.lisp

diff --git a/src/assembly/assemfile.lisp b/src/assembly/assemfile.lisp
index d17a5a3..dd2cabf 100644 (file)
--- a/src/assembly/assemfile.lisp
+++ b/src/assembly/assemfile.lisp
@@ -11,36 +11,30 @@
 ;;;; files for more information.
 
 (in-package "SB!C")
 ;;;; files for more information.
 
 (in-package "SB!C")

-
-(file-comment
-  "$Header$")

 \f
 \f

-(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.
 (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))
         (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)
         (*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")))
        (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*)))
          (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*
                                     length
                                     *fixups*
                                     *entry-points*

-                                    *lap-output-file*))
+                                    lap-fasl-output))

          (setq won t))
          (setq won t))

-      (close-fasl-file *lap-output-file* (not won)))
+      (close-fasl-output lap-fasl-output (not won)))

     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)
   (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)))
       (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
        ,@(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))
       `(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))
                     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))
                   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)
                     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))))
                           (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
                      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
                     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)
                     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)))
          (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)))))
          (emit-assemble name options regs code)
          (emit-vop name options regs)))))