src/compiler/target-main.lisp

   1 ;;;; functions from classic CMU CL src/compiler/main.lisp which are
   2 ;;;; needed only (and which may make sense only) on the
   3 ;;;; cross-compilation target, not the cross-compilation host
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 (in-package "SB!C")
  15
  16 (file-comment
  17   "$Header$")
  18 \f
  19 ;;;; COMPILE and UNCOMPILE
  20
  21 (defun get-lambda-to-compile (definition)
  22   (if (consp definition)
  23       definition
  24       (multiple-value-bind (def env-p)
  25                            (function-lambda-expression definition)
  26         (when env-p
  27           (error "~S was defined in a non-null environment." definition))
  28         (unless def
  29           (error "Can't find a definition for ~S." definition))
  30         def)))
  31
  32 ;;; Find the function that is being compiled by COMPILE and bash its name to
  33 ;;; NAME. We also substitute for any references to name so that recursive
  34 ;;; calls will be compiled direct. Lambda is the top-level lambda for the
  35 ;;; compilation. A REF for the real function is the only thing in the
  36 ;;; top-level lambda other than the bind and return, so it isn't too hard to
  37 ;;; find.
  38 (defun compile-fix-function-name (lambda name)
  39   (declare (type clambda lambda) (type (or symbol cons) name))
  40   (when name
  41     (let ((fun (ref-leaf
  42                 (continuation-next
  43                  (node-cont (lambda-bind lambda))))))
  44       (setf (leaf-name fun) name)
  45       (let ((old (gethash name *free-functions*)))
  46         (when old (substitute-leaf fun old)))
  47       name)))
  48
  49 (defun compile (name &optional (definition (fdefinition name)))
  50   #!+sb-doc
  51   "Compiles the function whose name is Name. If Definition is supplied,
  52   it should be a lambda expression that is compiled and then placed in the
  53   function cell of Name. If Name is Nil, the compiled code object is
  54   returned."
  55   (with-compilation-values
  56     (sb!xc:with-compilation-unit ()
  57       (let* ((*info-environment* (or *backend-info-environment*
  58                                      *info-environment*))
  59              (*lexenv* (make-null-lexenv))
  60              (form `#',(get-lambda-to-compile definition))
  61              (*source-info* (make-lisp-source-info form))
  62              (*top-level-lambdas* ())
  63              (*converting-for-interpreter* nil)
  64              (*block-compile* nil)
  65              (*compiler-error-bailout*
  66               #'(lambda ()
  67                   (compiler-mumble
  68                    "~2&fatal error, aborting compilation~%")
  69                   (return-from compile (values nil t nil))))
  70              (*current-path* nil)
  71              (*last-source-context* nil)
  72              (*last-original-source* nil)
  73              (*last-source-form* nil)
  74              (*last-format-string* nil)
  75              (*last-format-args* nil)
  76              (*last-message-count* 0)
  77              (*compile-object* (make-core-object))
  78              (*gensym-counter* 0)
  79              ;; FIXME: ANSI doesn't say anything about CL:COMPILE
  80              ;; interacting with these variables, so we shouldn't. As
  81              ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
  82              ;; binding these variables, so as a quick hack we do so
  83              ;; too. But a proper implementation would have verbosity
  84              ;; controlled by function arguments and lexical variables.
  85              (*compile-verbose* nil)
  86              (*compile-print* nil))
  87         (clear-stuff)
  88         (find-source-paths form 0)
  89         (let ((lambda (ir1-top-level form '(original-source-start 0 0) t)))
  90
  91           (compile-fix-function-name lambda name)
  92           (let* ((component
  93                   (block-component (node-block (lambda-bind lambda))))
  94                  (*all-components* (list component)))
  95             (local-call-analyze component))
  96
  97           (multiple-value-bind (components top-components)
  98                                (find-initial-dfo (list lambda))
  99             (let ((*all-components* (append components top-components)))
 100               (dolist (component *all-components*)
 101                 (compile-component component))))
 102
 103           (let* ((res1 (core-call-top-level-lambda lambda *compile-object*))
 104                  (result (or name res1)))
 105             (fix-core-source-info *source-info* *compile-object* res1)
 106             (when name
 107               (setf (fdefinition name) res1))
 108             result))))))