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