src/compiler/envanal.lisp

   1 ;;;; This file implements the environment analysis phase for the
   2 ;;;; compiler. This phase annotates IR1 with a hierarchy environment
   3 ;;;; structures, determining the environment that each Lambda
   4 ;;;; allocates its variables and finding what values are closed over
   5 ;;;; by each environment.
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; This software is derived from the CMU CL system, which was
  11 ;;;; written at Carnegie Mellon University and released into the
  12 ;;;; public domain. The software is in the public domain and is
  13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  14 ;;;; files for more information.
  15
  16 (in-package "SB!C")
  17
  18 ;;; Do environment analysis on the code in Component. This involves
  19 ;;; various things:
  20 ;;;  1. Make an Environment structure for each non-let lambda, assigning
  21 ;;;     the lambda-environment for all lambdas.
  22 ;;;  2. Find all values that need to be closed over by each environment.
  23 ;;;  3. Scan the blocks in the component closing over non-local-exit
  24 ;;;     continuations.
  25 ;;;  4. Delete all non-top-level functions with no references. This
  26 ;;;     should only get functions with non-NULL kinds, since normal
  27 ;;;     functions are deleted when their references go to zero. If
  28 ;;;     *byte-compiling*, then don't delete optional entries with no
  29 ;;;     references, since the byte interpreter wants to call entries
  30 ;;;     that the XEP doesn't.
  31 (defun environment-analyze (component)
  32   (declare (type component component))
  33   (aver (every (lambda (x)
  34                  (eq (functional-kind x) :deleted))
  35                (component-new-functions component)))
  36   (setf (component-new-functions component) ())
  37   (dolist (fun (component-lambdas component))
  38     (reinit-lambda-environment fun))
  39   (dolist (fun (component-lambdas component))
  40     (compute-closure fun)
  41     (dolist (let (lambda-lets fun))
  42       (compute-closure let)))
  43
  44   (find-non-local-exits component)
  45   (find-cleanup-points component)
  46   (tail-annotate component)
  47
  48   (dolist (fun (component-lambdas component))
  49     (when (null (leaf-refs fun))
  50       (let ((kind (functional-kind fun)))
  51         (unless (or (eq kind :top-level)
  52                     (and *byte-compiling* (eq kind :optional)))
  53           (aver (member kind '(:optional :cleanup :escape)))
  54           (setf (functional-kind fun) nil)
  55           (delete-functional fun)))))
  56
  57   (values))
  58
  59 ;;; Called on component with top-level lambdas before the compilation of the
  60 ;;; associated non-top-level code to detect closed over top-level variables.
  61 ;;; We just do COMPUTE-CLOSURE on all the lambdas. This will pre-allocate
  62 ;;; environments for all the functions with closed-over top-level variables.
  63 ;;; The post-pass will use the existing structure, rather than allocating a new
  64 ;;; one. We return true if we discover any possible closure vars.
  65 (defun pre-environment-analyze-top-level (component)
  66   (declare (type component component))
  67   (let ((found-it nil))
  68     (dolist (lambda (component-lambdas component))
  69       (when (compute-closure lambda)
  70         (setq found-it t))
  71       (dolist (let (lambda-lets lambda))
  72         (when (compute-closure let)
  73           (setq found-it t))))
  74     found-it))
  75
  76 ;;; If Fun has an environment, return it, otherwise assign one.
  77 (defun get-lambda-environment (fun)
  78   (declare (type clambda fun))
  79   (let* ((fun (lambda-home fun))
  80          (env (lambda-environment fun)))
  81     (or env
  82         (let ((res (make-environment :function fun)))
  83           (setf (lambda-environment fun) res)
  84           (dolist (lambda (lambda-lets fun))
  85             (setf (lambda-environment lambda) res))
  86           res))))
  87
  88 ;;; If Fun has no environment, assign one, otherwise clean up variables that
  89 ;;; have no sets or refs. If a var has no references, we remove it from the
  90 ;;; closure. If it has no sets, we clear the INDIRECT flag. This is
  91 ;;; necessary because pre-analysis is done before optimization.
  92 (defun reinit-lambda-environment (fun)
  93   (let ((old (lambda-environment (lambda-home fun))))
  94     (cond (old
  95            (setf (environment-closure old)
  96                  (delete-if #'(lambda (x)
  97                                 (and (lambda-var-p x)
  98                                      (null (leaf-refs x))))
  99                             (environment-closure old)))
 100            (flet ((clear (fun)
 101                     (dolist (var (lambda-vars fun))
 102                       (unless (lambda-var-sets var)
 103                         (setf (lambda-var-indirect var) nil)))))
 104              (clear fun)
 105              (dolist (let (lambda-lets fun))
 106                (clear let))))
 107           (t
 108            (get-lambda-environment fun))))
 109   (values))
 110
 111 ;;; Get node's environment, assigning one if necessary.
 112 (defun get-node-environment (node)
 113   (declare (type node node))
 114   (get-lambda-environment (node-home-lambda node)))
 115
 116 ;;; Find any variables in Fun with references outside of the home
 117 ;;; environment and close over them. If a closed over variable is set, then we
 118 ;;; set the Indirect flag so that we will know the closed over value is really
 119 ;;; a pointer to the value cell. We also warn about unreferenced variables
 120 ;;; here, just because it's a convenient place to do it. We return true if we
 121 ;;; close over anything.
 122 (defun compute-closure (fun)
 123   (declare (type clambda fun))
 124   (let ((env (get-lambda-environment fun))
 125         (did-something nil))
 126     (note-unreferenced-vars fun)
 127     (dolist (var (lambda-vars fun))
 128       (dolist (ref (leaf-refs var))
 129         (let ((ref-env (get-node-environment ref)))
 130           (unless (eq ref-env env)
 131             (when (lambda-var-sets var)
 132               (setf (lambda-var-indirect var) t))
 133             (setq did-something t)
 134             (close-over var ref-env env))))
 135       (dolist (set (basic-var-sets var))
 136         (let ((set-env (get-node-environment set)))
 137           (unless (eq set-env env)
 138             (setq did-something t)
 139             (setf (lambda-var-indirect var) t)
 140             (close-over var set-env env)))))
 141     did-something))
 142
 143 ;;; Make sure that Thing is closed over in Ref-Env and in all environments
 144 ;;; for the functions that reference Ref-Env's function (not just calls.)
 145 ;;; Home-Env is Thing's home environment. When we reach the home environment,
 146 ;;; we stop propagating the closure.
 147 (defun close-over (thing ref-env home-env)
 148   (declare (type environment ref-env home-env))
 149   (cond ((eq ref-env home-env))
 150         ((member thing (environment-closure ref-env)))
 151         (t
 152          (push thing (environment-closure ref-env))
 153          (dolist (call (leaf-refs (environment-function ref-env)))
 154            (close-over thing (get-node-environment call) home-env))))
 155   (values))
 156 \f
 157 ;;;; non-local exit
 158
 159 ;;; Insert the entry stub before the original exit target, and add a new
 160 ;;; entry to the Environment-Nlx-Info. The %NLX-Entry call in the stub is
 161 ;;; passed the NLX-Info as an argument so that the back end knows what entry is
 162 ;;; being done.
 163 ;;;
 164 ;;; The link from the Exit block to the entry stub is changed to be a link to
 165 ;;; the component head. Similarly, the Exit block is linked to the component
 166 ;;; tail. This leaves the entry stub reachable, but makes the flow graph less
 167 ;;; confusing to flow analysis.
 168 ;;;
 169 ;;; If a catch or an unwind-protect, then we set the Lexenv for the last node
 170 ;;; in the cleanup code to be the enclosing environment, to represent the fact
 171 ;;; that the binding was undone as a side-effect of the exit. This will cause
 172 ;;; a lexical exit to be broken up if we are actually exiting the scope (i.e.
 173 ;;; a BLOCK), and will also do any other cleanups that may have to be done on
 174 ;;; the way.
 175 (defun insert-nlx-entry-stub (exit env)
 176   (declare (type environment env) (type exit exit))
 177   (let* ((exit-block (node-block exit))
 178          (next-block (first (block-succ exit-block)))
 179          (cleanup (entry-cleanup (exit-entry exit)))
 180          (info (make-nlx-info :cleanup cleanup
 181                               :continuation (node-cont exit)))
 182          (entry (exit-entry exit))
 183          (new-block (insert-cleanup-code exit-block next-block
 184                                          entry
 185                                          `(%nlx-entry ',info)
 186                                          (entry-cleanup entry)))
 187          (component (block-component new-block)))
 188     (unlink-blocks exit-block new-block)
 189     (link-blocks exit-block (component-tail component))
 190     (link-blocks (component-head component) new-block)
 191
 192     (setf (nlx-info-target info) new-block)
 193     (push info (environment-nlx-info env))
 194     (push info (cleanup-nlx-info cleanup))
 195     (when (member (cleanup-kind cleanup) '(:catch :unwind-protect))
 196       (setf (node-lexenv (block-last new-block))
 197             (node-lexenv entry))))
 198
 199   (values))
 200
 201 ;;; Do stuff necessary to represent a non-local exit from the node Exit into
 202 ;;; Env. This is called for each non-local exit node, of which there may be
 203 ;;; several per exit continuation. This is what we do:
 204 ;;; -- If there isn't any NLX-Info entry in the environment, make an entry
 205 ;;;    stub, otherwise just move the exit block link to the component tail.
 206 ;;; -- Close over the NLX-Info in the exit environment.
 207 ;;; -- If the exit is from an :Escape function, then substitute a constant
 208 ;;;    reference to NLX-Info structure for the escape function reference. This
 209 ;;;    will cause the escape function to be deleted (although not removed from
 210 ;;;    the DFO.)  The escape function is no longer needed, and we don't want to
 211 ;;;    emit code for it. We then also change the %NLX-ENTRY call to use
 212 ;;;    the NLX continuation so that there will be a use to represent the NLX
 213 ;;;    use.
 214 (defun note-non-local-exit (env exit)
 215   (declare (type environment env) (type exit exit))
 216   (let ((entry (exit-entry exit))
 217         (cont (node-cont exit))
 218         (exit-fun (node-home-lambda exit)))
 219
 220     (if (find-nlx-info entry cont)
 221         (let ((block (node-block exit)))
 222           (aver (= (length (block-succ block)) 1))
 223           (unlink-blocks block (first (block-succ block)))
 224           (link-blocks block (component-tail (block-component block))))
 225         (insert-nlx-entry-stub exit env))
 226
 227     (let ((info (find-nlx-info entry cont)))
 228       (aver info)
 229       (close-over info (node-environment exit) env)
 230       (when (eq (functional-kind exit-fun) :escape)
 231         (mapc #'(lambda (x)
 232                   (setf (node-derived-type x) *wild-type*))
 233               (leaf-refs exit-fun))
 234         (substitute-leaf (find-constant info) exit-fun)
 235         (let ((node (block-last (nlx-info-target info))))
 236           (delete-continuation-use node)
 237           (add-continuation-use node (nlx-info-continuation info))))))
 238
 239   (values))
 240
 241 ;;; Iterate over the Exits in Component, calling Note-Non-Local-Exit when we
 242 ;;; find a block that ends in a non-local Exit node. We also ensure that all
 243 ;;; Exit nodes are either non-local or degenerate by calling IR1-Optimize-Exit
 244 ;;; on local exits. This makes life simpler for later phases.
 245 (defun find-non-local-exits (component)
 246   (declare (type component component))
 247   (dolist (lambda (component-lambdas component))
 248     (dolist (entry (lambda-entries lambda))
 249       (dolist (exit (entry-exits entry))
 250         (let ((target-env (node-environment entry)))
 251           (if (eq (node-environment exit) target-env)
 252               (unless *converting-for-interpreter*
 253                 (maybe-delete-exit exit))
 254               (note-non-local-exit target-env exit))))))
 255
 256   (values))
 257 \f
 258 ;;;; cleanup emission
 259
 260 ;;; Zoom up the cleanup nesting until we hit Cleanup1, accumulating cleanup
 261 ;;; code as we go. When we are done, convert the cleanup code in an implicit
 262 ;;; MV-Prog1. We have to force local call analysis of new references to
 263 ;;; Unwind-Protect cleanup functions. If we don't actually have to do
 264 ;;; anything, then we don't insert any cleanup code.
 265 ;;;
 266 ;;; If we do insert cleanup code, we check that Block1 doesn't end in a "tail"
 267 ;;; local call.
 268 ;;;
 269 ;;; We don't need to adjust the ending cleanup of the cleanup block, since
 270 ;;; the cleanup blocks are inserted at the start of the DFO, and are thus never
 271 ;;; scanned.
 272 (defun emit-cleanups (block1 block2)
 273   (declare (type cblock block1 block2))
 274   (collect ((code)
 275             (reanalyze-funs))
 276     (let ((cleanup2 (block-start-cleanup block2)))
 277       (do ((cleanup (block-end-cleanup block1)
 278                     (node-enclosing-cleanup (cleanup-mess-up cleanup))))
 279           ((eq cleanup cleanup2))
 280         (let* ((node (cleanup-mess-up cleanup))
 281                (args (when (basic-combination-p node)
 282                        (basic-combination-args node))))
 283           (ecase (cleanup-kind cleanup)
 284             (:special-bind
 285              (code `(%special-unbind ',(continuation-value (first args)))))
 286             (:catch
 287              (code `(%catch-breakup)))
 288             (:unwind-protect
 289              (code `(%unwind-protect-breakup))
 290              (let ((fun (ref-leaf (continuation-use (second args)))))
 291                (reanalyze-funs fun)
 292                (code `(%funcall ,fun))))
 293             ((:block :tagbody)
 294              (dolist (nlx (cleanup-nlx-info cleanup))
 295                (code `(%lexical-exit-breakup ',nlx)))))))
 296
 297       (when (code)
 298         (aver (not (node-tail-p (block-last block1))))
 299         (insert-cleanup-code block1 block2
 300                              (block-last block1)
 301                              `(progn ,@(code)))
 302         (dolist (fun (reanalyze-funs))
 303           (local-call-analyze-1 fun)))))
 304
 305   (values))
 306
 307 ;;; Loop over the blocks in component, calling Emit-Cleanups when we see a
 308 ;;; successor in the same environment with a different cleanup. We ignore the
 309 ;;; cleanup transition if it is to a cleanup enclosed by the current cleanup,
 310 ;;; since in that case we are just messing up the environment, hence this is
 311 ;;; not the place to clean it.
 312 (defun find-cleanup-points (component)
 313   (declare (type component component))
 314   (do-blocks (block1 component)
 315     (let ((env1 (block-environment block1))
 316           (cleanup1 (block-end-cleanup block1)))
 317       (dolist (block2 (block-succ block1))
 318         (when (block-start block2)
 319           (let ((env2 (block-environment block2))
 320                 (cleanup2 (block-start-cleanup block2)))
 321             (unless (or (not (eq env2 env1))
 322                         (eq cleanup1 cleanup2)
 323                         (and cleanup2
 324                              (eq (node-enclosing-cleanup
 325                                   (cleanup-mess-up cleanup2))
 326                                  cleanup1)))
 327               (emit-cleanups block1 block2)))))))
 328   (values))
 329
 330 ;;; Mark all tail-recursive uses of function result continuations with the
 331 ;;; corresponding tail-set. Nodes whose type is NIL (i.e. don't return) such
 332 ;;; as calls to ERROR are never annotated as tail in order to preserve
 333 ;;; debugging information.
 334 (defun tail-annotate (component)
 335   (declare (type component component))
 336   (dolist (fun (component-lambdas component))
 337     (let ((ret (lambda-return fun)))
 338       (when ret
 339         (let ((result (return-result ret)))
 340           (do-uses (use result)
 341             (when (and (immediately-used-p result use)
 342                      (or (not (eq (node-derived-type use) *empty-type*))
 343                          (not (basic-combination-p use))
 344                          (eq (basic-combination-kind use) :local)))
 345                 (setf (node-tail-p use) t)))))))
 346   (values))