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 ;;;; CL:COMPILE
  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 ;;; Handle the nontrivial case of CL:COMPILE.
  47 (defun actually-compile (name definition)
  48   (with-compilation-values
  49     (sb!xc:with-compilation-unit ()
  50       (let* (;; FIXME: Do we need this rebinding here? It's a literal
  51              ;; translation of the old CMU CL rebinding to
  52              ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*),
  53              ;; and it's not obvious whether the rebinding to itself is
  54              ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
  55              (*info-environment* *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              (*block-compile* nil)
  61              (*compiler-error-bailout*
  62               #'(lambda ()
  63                   (compiler-mumble
  64                    "~2&fatal error, aborting compilation~%")
  65                   (return-from actually-compile (values nil t nil))))
  66              (*current-path* nil)
  67              (*last-source-context* nil)
  68              (*last-original-source* nil)
  69              (*last-source-form* nil)
  70              (*last-format-string* nil)
  71              (*last-format-args* nil)
  72              (*last-message-count* 0)
  73              (*compile-object* (make-core-object))
  74              (*gensym-counter* 0)
  75              ;; FIXME: ANSI doesn't say anything about CL:COMPILE
  76              ;; interacting with these variables, so we shouldn't. As
  77              ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
  78              ;; binding these variables, so as a quick hack we do so
  79              ;; too. But a proper implementation would have verbosity
  80              ;; controlled by function arguments and lexical variables.
  81              (*compile-verbose* nil)
  82              (*compile-print* nil))
  83         (clear-stuff)
  84         (find-source-paths form 0)
  85         (let ((lambda (ir1-top-level form '(original-source-start 0 0) t)))
  86
  87           (compile-fix-function-name lambda name)
  88           (let* ((component
  89                   (block-component (node-block (lambda-bind lambda))))
  90                  (*all-components* (list component)))
  91             (local-call-analyze component))
  92
  93           (multiple-value-bind (components top-components)
  94                                (find-initial-dfo (list lambda))
  95             (let ((*all-components* (append components top-components)))
  96               (dolist (component *all-components*)
  97                 (compile-component component))))
  98
  99           (let ((compiled-fun (core-call-top-level-lambda lambda
 100                                                           *compile-object*)))
 101             (fix-core-source-info *source-info* *compile-object* compiled-fun)
 102             compiled-fun))))))
 103
 104 (defun compile (name &optional (definition (fdefinition name)))
 105   #!+sb-doc
 106   "Coerce DEFINITION (by default, the function whose name is NAME)
 107   to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
 108   where if NAME is NIL, THING is the result of compilation, and
 109   otherwise THING is NAME. When NAME is not NIL, the compiled function
 110   is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
 111   (FDEFINITION NAME) otherwise."
 112   (multiple-value-bind (compiled-definition warnings-p failure-p)
 113       (if (compiled-function-p definition)
 114           (values definition nil nil)
 115           (actually-compile name definition))
 116     (cond (name
 117            (if (macro-function name)
 118                (setf (macro-function name) compiled-definition)
 119                (setf (fdefinition name) compiled-definition))
 120            (values name warnings-p failure-p))
 121           (t
 122            (values compiled-definition warnings-p failure-p)))))