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-designator)
  19   (if (consp definition-designator)
  20       definition-designator
  21       (multiple-value-bind (definition env-p)
  22                            (function-lambda-expression definition-designator)
  23         (when env-p
  24           (error "~S was defined in a non-null environment."
  25                  definition-designator))
  26         (unless definition
  27           (error "can't find a definition for ~S" definition-designator))
  28         definition)))
  29
  30 ;;; Handle the nontrivial case of CL:COMPILE.
  31 ;;;
  32 ;;; If ERRORP is true signals an error immediately -- otherwise returns
  33 ;;; a function that will signal the error.
  34 (defun actually-compile (name definition *lexenv* source-info tlf errorp)
  35   (let ((source-paths (when source-info *source-paths*)))
  36     (with-compilation-values
  37       (sb!xc:with-compilation-unit ()
  38         ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
  39         ;; few changes. Once things are stable, the shared bindings
  40         ;; probably be merged back together into some shared utility
  41         ;; macro, or perhaps both merged into one of the existing utility
  42         ;; macros SB-C::WITH-COMPILATION-VALUES or
  43         ;; CL:WITH-COMPILATION-UNIT.
  44         (with-source-paths
  45           (prog* ((tlf (or tlf 0))
  46                   ;; If we have a source-info from LOAD, we will
  47                   ;; also have a source-paths already set up -- so drop
  48                   ;; the ones from WITH-COMPILATION-VALUES.
  49                   (*source-paths* (or source-paths *source-paths*))
  50                   ;; FIXME: Do we need the *INFO-ENVIRONMENT* rebinding
  51                   ;; here? It's a literal translation of the old CMU CL
  52                   ;; rebinding to (OR *BACKEND-INFO-ENVIRONMENT*
  53                   ;; *INFO-ENVIRONMENT*), and it's not obvious whether the
  54                   ;; rebinding to itself is needed now that SBCL doesn't
  55                   ;; need *BACKEND-INFO-ENVIRONMENT*.
  56                   (*info-environment* *info-environment*)
  57                   (form (get-lambda-to-compile definition))
  58                   (*source-info* (or source-info
  59                                   (make-lisp-source-info
  60                                    form :parent *source-info*)))
  61                   (*toplevel-lambdas* ())
  62                   (*block-compile* nil)
  63                   (*allow-instrumenting* nil)
  64                   (*code-coverage-records* nil)
  65                   (*code-coverage-blocks* 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                   (*last-error-context* nil)
  74                   (*gensym-counter* 0)
  75                   ;; KLUDGE: This rebinding of policy is necessary so that
  76                   ;; forms such as LOCALLY at the REPL actually extend the
  77                   ;; compilation policy correctly.  However, there is an
  78                   ;; invariant that is potentially violated: future
  79                   ;; refactoring must not allow this to be done in the file
  80                   ;; compiler.  At the moment we're clearly alright, as we
  81                   ;; call %COMPILE with a core-object, not a fasl-stream,
  82                   ;; but caveat future maintainers. -- CSR, 2002-10-27
  83                   (*policy* (lexenv-policy *lexenv*))
  84                   ;; see above
  85                   (*handled-conditions* (lexenv-handled-conditions *lexenv*))
  86                   ;; ditto
  87                   (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))
  88                   ;; FIXME: ANSI doesn't say anything about CL:COMPILE
  89                   ;; interacting with these variables, so we shouldn't. As
  90                   ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
  91                   ;; binding these variables, so as a quick hack we do so
  92                   ;; too. But a proper implementation would have verbosity
  93                   ;; controlled by function arguments and lexical variables.
  94                   (*compile-verbose* nil)
  95                   (*compile-print* nil)
  96                   (oops nil))
  97              (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
  98                (unless source-paths
  99                  (find-source-paths form tlf))
 100                (let ((*compiler-error-bailout*
 101                        (lambda (e)
 102                          (setf oops e)
 103                          ;; Unwind the compiler frames: users want the know where
 104                          ;; the error came from, not how the compiler got there.
 105                          (go :error))))
 106                  (return
 107                    (with-world-lock ()
 108                      (%compile form (make-core-object)
 109                                :name name
 110                                :path `(original-source-start 0 ,tlf))))))
 111            :error
 112              ;; Either signal the error right away, or return a function that
 113              ;; will signal the corresponding COMPILED-PROGRAM-ERROR. This is so
 114              ;; that we retain our earlier behaviour when called with erronous
 115              ;; lambdas via %SIMPLE-EVAL. We could legally do just either one
 116              ;; always, but right now keeping the old behaviour seems like less
 117              ;; painful option: compiler.pure.lisp is full of tests that make all
 118              ;; sort of assumptions about when which things are signalled. FIXME,
 119              ;; probably.
 120              (if errorp
 121                  (error oops)
 122                  (let ((message (princ-to-string oops))
 123                        (source (source-to-string form)))
 124                    (return
 125                      (lambda (&rest arguments)
 126                        (declare (ignore arguments))
 127                        (error 'compiled-program-error
 128                               :message message
 129                               :source source)))))))))))
 130
 131 (defun compile-in-lexenv (name definition lexenv
 132                           &optional source-info tlf errorp)
 133   (multiple-value-bind (compiled-definition warnings-p failure-p)
 134       (cond
 135         #!+sb-eval
 136         ((sb!eval:interpreted-function-p definition)
 137          (multiple-value-bind (definition lexenv)
 138              (sb!eval:prepare-for-compile definition)
 139            (actually-compile name definition lexenv source-info tlf errorp)))
 140         ((compiled-function-p definition)
 141          (values definition nil nil))
 142         (t
 143          (actually-compile name definition lexenv source-info tlf errorp)))
 144     (check-type compiled-definition compiled-function)
 145     (cond (name
 146            (if (and (symbolp name)
 147                     (macro-function name))
 148                (setf (macro-function name) compiled-definition)
 149                (setf (fdefinition name) compiled-definition))
 150            (values name warnings-p failure-p))
 151           (t
 152            (values compiled-definition warnings-p failure-p)))))
 153
 154 (defun compile (name &optional (definition (or (and (symbolp name)
 155                                                     (macro-function name))
 156                                                (fdefinition name))))
 157   #!+sb-doc
 158   "Produce a compiled function from DEFINITION. If DEFINITION is a
 159 lambda-expression, it is coerced to a function. If DEFINITION is an
 160 interpreted function, it is compiled. If DEFINITION is already a compiled
 161 function, it is used as-is. (Future versions of SBCL might try to
 162 recompile the existing definition, but this is not currently supported.)
 163
 164 If NAME is NIL, the compiled function is returned as the primary value.
 165 Otherwise the resulting compiled function replaces existing function
 166 definition of NAME, and NAME is returned as primary value; if NAME is a symbol
 167 tha names a macro, its macro function is replaced and NAME is returned as
 168 primary value.
 169
 170 Also returns secondary value which is true if any conditions of type WARNING
 171 occur during the compilation, and NIL otherwise.
 172
 173 Tertiary value is true if any conditions of type ERROR, or WARNING that are
 174 not STYLE-WARNINGs occur during compilation, and NIL otherwise.
 175 "
 176   (compile-in-lexenv name definition (make-null-lexenv)))