src/compiler/eval-comp.lisp

   1 ;;;; This file represents the current state of on-going development on
   2 ;;;; compiler hooks for an interpreter that takes the compiler's IR1 of
   3 ;;;; a program.
   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 ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
  17 (declaim (special *constants* *free-variables* *component-being-compiled*
  18                   *code-vector* *next-location* *result-fixups*
  19                   *free-functions* *source-paths* *failed-optimizations*
  20                   *seen-blocks* *seen-functions* *list-conflicts-table*
  21                   *continuation-number* *continuation-numbers*
  22                   *number-continuations* *tn-id* *tn-ids* *id-tns*
  23                   *label-ids* *label-id* *id-labels*
  24                   *compiler-error-count* *compiler-warning-count*
  25                   *compiler-style-warning-count* *compiler-note-count*
  26                   *compiler-error-bailout*
  27                   #!+sb-show *compiler-trace-output*
  28                   *last-source-context* *last-original-source*
  29                   *last-source-form* *last-format-string* *last-format-args*
  30                   *last-message-count* *check-consistency*
  31                   *all-components* *converting-for-interpreter*
  32                   *source-info* *block-compile* *current-path*
  33                   *current-component* *lexenv*))
  34 \f
  35 ;;; Translate form into the compiler's IR1 and perform environment
  36 ;;; analysis. This is sort of a combination of COMPILE-FILE,
  37 ;;; SUB-COMPILE-FILE, COMPILE-TOP-LEVEL, and COMPILE-COMPONENT.
  38 (defun compile-for-eval (form)
  39   (with-ir1-namespace
  40     (let* ((*block-compile* nil)
  41            (*lexenv* (make-null-lexenv))
  42            (*compiler-error-bailout*
  43             #'(lambda () (error "fatal error, aborting evaluation")))
  44            (*current-path* nil)
  45            (*last-source-context* nil)
  46            (*last-original-source* nil)
  47            (*last-source-form* nil)
  48            (*last-format-string* nil)
  49            (*last-format-args* nil)
  50            (*last-message-count* 0)
  51            ;; These are now bound by WITH-COMPILATION-UNIT. -- WHN 20000308
  52            #+nil (*compiler-error-count* 0)
  53            #+nil (*compiler-warning-count* 0)
  54            #+nil (*compiler-style-warning-count* 0)
  55            #+nil (*compiler-note-count* 0)
  56            (*source-info* (make-lisp-source-info form))
  57            (*converting-for-interpreter* t)
  58            (*gensym-counter* 0)
  59            (*warnings-p* nil)
  60            (*failure-p* nil))
  61
  62       (clear-stuff nil)
  63       (find-source-paths form 0)
  64       ;; This LET comes from COMPILE-TOP-LEVEL.
  65       ;; The noted DOLIST is a splice from a call that COMPILE-TOP-LEVEL makes.
  66       (sb!xc:with-compilation-unit ()
  67         (let ((lambdas (list (ir1-top-level form
  68                                             '(original-source-start 0 0)
  69                                             t))))
  70           (declare (list lambdas))
  71           (dolist (lambda lambdas)
  72             (let* ((component
  73                     (block-component (node-block (lambda-bind lambda))))
  74                    (*all-components* (list component)))
  75               (local-call-analyze component)))
  76           (multiple-value-bind (components top-components)
  77               (find-initial-dfo lambdas)
  78             (let ((*all-components* (append components top-components)))
  79               (when *check-consistency*
  80                 (check-ir1-consistency *all-components*))
  81               ;; This DOLIST body comes from the beginning of
  82               ;; COMPILE-COMPONENT.
  83               (dolist (component *all-components*)
  84                 (ir1-finalize component)
  85                 (let ((*component-being-compiled* component))
  86                   (environment-analyze component))
  87                 (annotate-component-for-eval component))
  88             (when *check-consistency*
  89               (check-ir1-consistency *all-components*))))
  90           (car lambdas))))))
  91 \f
  92 ;;;; annotating IR1 for interpretation
  93
  94 (defstruct (lambda-eval-info (:constructor make-lambda-eval-info
  95                                            (frame-size args-passed entries))
  96                              (:copier nil))
  97   frame-size            ; number of stack locations needed to hold locals
  98   args-passed           ; number of referenced arguments passed to lambda
  99   entries               ; a-list mapping entry nodes to stack locations
 100   (function nil))       ; a function object corresponding to this lambda
 101 (def!method print-object ((obj lambda-eval-info) str)
 102   (print-unreadable-object (obj str :type t)))
 103
 104 (defstruct (entry-node-info (:constructor make-entry-node-info
 105                                           (st-top nlx-tag))
 106                             (:copier nil))
 107   st-top        ; stack top when we encounter the entry node
 108   nlx-tag)      ; tag to which to throw to get back entry node's context
 109 (def!method print-object ((obj entry-node-info) str)
 110   (print-unreadable-object (obj str :type t)))
 111
 112 ;;; Some compiler funny functions have definitions, so the interpreter
 113 ;;; can call them. These require special action to coordinate the
 114 ;;; interpreter, system call stack, and the environment. The
 115 ;;; annotation prepass marks the references to these as :UNUSED, so
 116 ;;; the interpreter doesn't try to fetch functions through these
 117 ;;; undefined symbols.
 118 (defconstant undefined-funny-funs
 119   '(%special-bind %special-unbind %more-arg-context %unknown-values %catch
 120     %unwind-protect %catch-breakup %unwind-protect-breakup
 121     %lexical-exit-breakup %continue-unwind %nlx-entry))
 122
 123 ;;; Some kinds of functions are only passed as arguments to funny
 124 ;;; functions, and are never actually evaluated at run time.
 125 (defconstant non-closed-function-kinds '(:cleanup :escape))
 126
 127 ;;; This annotates continuations, lambda-vars, and lambdas. For each
 128 ;;; continuation, we cache how its destination uses its value. This
 129 ;;; only buys efficiency when the code executes more than once, but
 130 ;;; the overhead of this part of the prepass for code executed only
 131 ;;; once should be negligible.
 132 ;;;
 133 ;;; As a special case to aid interpreting local function calls, we
 134 ;;; sometimes note the continuation as :unused. This occurs when there
 135 ;;; is a local call, and there is no actual function object to call;
 136 ;;; we mark the continuation as :unused since there is nothing to push
 137 ;;; on the interpreter's stack. Normally we would see a reference to a
 138 ;;; function that we would push on the stack to later pop and apply to
 139 ;;; the arguments on the stack. To determine when we have a local call
 140 ;;; with no real function object, we look at the node to see whether
 141 ;;; it is a reference with a destination that is a :local combination
 142 ;;; whose function is the reference node's continuation.
 143 ;;;
 144 ;;; After checking for virtual local calls, we check for funny
 145 ;;; functions the compiler refers to for calling to note certain
 146 ;;; operations. These functions are undefined, and if the interpreter
 147 ;;; tried to reference the function cells of these symbols, it would
 148 ;;; get an error. We mark the continuations delivering the values of
 149 ;;; these references as :unused, so the reference never takes place.
 150 ;;;
 151 ;;; For each lambda-var, including a LAMBDA's vars and its LET's vars,
 152 ;;; we note the stack offset used to access and store that variable.
 153 ;;; Then we note the lambda with the total number of variables, so we
 154 ;;; know how big its stack frame is. Also in the lambda's info is the
 155 ;;; number of its arguments that it actually references; the
 156 ;;; interpreter never pushes or pops an unreferenced argument, so we
 157 ;;; can't just use LENGTH on LAMBDA-VARS to know how many args the
 158 ;;; caller passed.
 159 ;;;
 160 ;;; For each entry node in a lambda, we associate in the
 161 ;;; lambda-eval-info the entry node with a stack offset. Evaluation
 162 ;;; code stores the frame pointer in this slot upon processing the
 163 ;;; entry node to aid stack cleanup and correct frame manipulation
 164 ;;; when processing exit nodes.
 165 (defun annotate-component-for-eval (component)
 166   (do-blocks (b component)
 167     (do-nodes (node cont b)
 168       (let* ((dest (continuation-dest cont))
 169              (refp (typep node 'ref))
 170              (leaf (if refp (ref-leaf node))))
 171         (setf (continuation-info cont)
 172               (cond ((and refp dest (typep dest 'basic-combination)
 173                           (eq (basic-combination-kind dest) :local)
 174                           (eq (basic-combination-fun dest) cont))
 175                      :unused)
 176                     ((and leaf (typep leaf 'global-var)
 177                           (eq (global-var-kind leaf) :global-function)
 178                           (member (sb!c::global-var-name leaf)
 179                                   undefined-funny-funs
 180                                   :test #'eq))
 181                      :unused)
 182                     ((and leaf (typep leaf 'clambda)
 183                           (member (functional-kind leaf)
 184                                   non-closed-function-kinds))
 185                      (aver (not (eq (functional-kind leaf) :escape)))
 186                      :unused)
 187                     (t
 188                      (typecase dest
 189                        ;; Change locations in eval.lisp that think
 190                        ;; :RETURN could occur.
 191                        ((or mv-combination creturn exit) :multiple)
 192                        (null :unused)
 193                        (t :single))))))))
 194   (dolist (lambda (component-lambdas component))
 195     (let ((locals-count 0)
 196           (args-passed-count 0))
 197       (dolist (var (lambda-vars lambda))
 198         (setf (leaf-info var) locals-count)
 199         (incf locals-count)
 200         (when (leaf-refs var) (incf args-passed-count)))
 201       (dolist (let (lambda-lets lambda))
 202         (dolist (var (lambda-vars let))
 203           (setf (leaf-info var) locals-count)
 204           (incf locals-count)))
 205       (let ((entries nil))
 206         (dolist (e (lambda-entries lambda))
 207           (ecase (process-entry-node-p e)
 208             (:blow-it-off)
 209             (:local-lexical-exit
 210              (push (cons e (make-entry-node-info locals-count nil))
 211                    entries)
 212              (incf locals-count))
 213             (:non-local-lexical-exit
 214              (push (cons e
 215                          (make-entry-node-info locals-count
 216                                                (incf locals-count)))
 217                    entries)
 218              (incf locals-count))))
 219         (setf (lambda-info lambda)
 220               (make-lambda-eval-info locals-count
 221                                      args-passed-count
 222                                      entries))))))
 223
 224 (defun process-entry-node-p (entry)
 225   (let ((entry-cleanup (entry-cleanup entry)))
 226     (dolist (nlx (environment-nlx-info (node-environment entry))
 227                  :local-lexical-exit)
 228       (let ((cleanup (nlx-info-cleanup nlx)))
 229         (when (eq entry-cleanup cleanup)
 230           (ecase (cleanup-kind cleanup)
 231             ((:block :tagbody)
 232              (return :non-local-lexical-exit))
 233             ((:catch :unwind-protect)
 234              (return :blow-it-off))))))))
 235
 236 ;;; Sometime consider annotations to exclude processing of exit nodes
 237 ;;; when we want to do a tail-p thing.
 238 \f
 239 ;;;; defining funny functions for interpreter
 240
 241 #|
 242 %listify-rest-args %more-arg %verify-argument-count %argument-count-error
 243 %odd-key-arguments-error %unknown-key-argument-error
 244 |#
 245
 246 (defun %verify-argument-count (supplied-args defined-args)
 247   (unless (= supplied-args defined-args)
 248     (error "Wrong argument count, wanted ~D and got ~D."
 249            defined-args supplied-args))
 250   (values))
 251
 252 ;;; Use (SETF SYMBOL-FUNCTION) instead of DEFUN so that the compiler
 253 ;;; doesn't try to compile the hidden %THROW MV-CALL in the throw below as
 254 ;;; a local recursive call.
 255 (setf (symbol-function '%throw)
 256       #'(lambda (tag &rest args)
 257           (throw tag (values-list args))))
 258
 259 (defun %more-arg (args index)
 260   (nth index args))
 261
 262 (defun %listify-rest-args (ptr count)
 263   (declare (ignore count))
 264   ptr)
 265
 266 (defun %more-arg-values (args start count)
 267   (values-list (subseq args start count)))
 268
 269 (defun %argument-count-error (args-passed-count)
 270   (error 'simple-program-error
 271          :format-control "wrong number of arguments passed: ~S"
 272          :format-arguments (list args-passed-count)))
 273
 274 (defun %odd-key-arguments-error ()
 275   (error 'simple-program-error
 276          :format-control "function called with odd number of &KEY arguments"
 277          :format-arguments nil))
 278
 279 (defun %unknown-key-argument-error (key-arg-name)
 280   (error 'simple-program-error
 281          :format-control "unknown &KEY argument: ~S"
 282          :format-arguments (list key-arg-name)))
 283
 284 (defun %cleanup-point ())
 285
 286 (defun value-cell-ref (x) (value-cell-ref x))