[Guile-commits] 05/05: Remove unused analyze-lexicals function

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 3d96c87cf82e3f2f4d73195cda6753ebe5e6ad74
Author: Andy Wingo <address@hidden>
AuthorDate: Wed Apr 29 11:13:33 2020 +0200

    Remove unused analyze-lexicals function
    
    * module/language/tree-il/analyze.scm (analyze-lexicals): Remove unused
      function; a holdover from GLIL days.
---
 module/language/tree-il/analyze.scm | 482 +-----------------------------------
 1 file changed, 1 insertion(+), 481 deletions(-)

diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index bc98f82..b4e1ad9 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -30,8 +30,7 @@
   #:use-module (system vm program)
   #:use-module (language tree-il)
   #:use-module (system base pmatch)
-  #:export (analyze-lexicals
-            analyze-tree
+  #:export (analyze-tree
             unused-variable-analysis
             unused-toplevel-analysis
             shadowed-toplevel-analysis
@@ -40,485 +39,6 @@
             arity-analysis
             format-analysis))
 
-;; Allocation is the process of assigning storage locations for lexical
-;; variables. A lexical variable has a distinct "address", or storage
-;; location, for each procedure in which it is referenced.
-;;
-;; A variable is "local", i.e., allocated on the stack, if it is
-;; referenced from within the procedure that defined it. Otherwise it is
-;; a "closure" variable. For example:
-;;
-;;    (lambda (a) a) ; a will be local
-;; `a' is local to the procedure.
-;;
-;;    (lambda (a) (lambda () a))
-;; `a' is local to the outer procedure, but a closure variable with
-;; respect to the inner procedure.
-;;
-;; If a variable is ever assigned, it needs to be heap-allocated
-;; ("boxed"). This is so that closures and continuations capture the
-;; variable's identity, not just one of the values it may have over the
-;; course of program execution. If the variable is never assigned, there
-;; is no distinction between value and identity, so closing over its
-;; identity (whether through closures or continuations) can make a copy
-;; of its value instead.
-;;
-;; Local variables are stored on the stack within a procedure's call
-;; frame. Their index into the stack is determined from their linear
-;; postion within a procedure's binding path:
-;; (let (0 1)
-;;   (let (2 3) ...)
-;;   (let (2) ...))
-;;   (let (2 3 4) ...))
-;; etc.
-;;
-;; This algorithm has the problem that variables are only allocated
-;; indices at the end of the binding path. If variables bound early in
-;; the path are not used in later portions of the path, their indices
-;; will not be recycled. This problem is particularly egregious in the
-;; expansion of `or':
-;;
-;;  (or x y z)
-;;    -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
-;;
-;; As you can see, the `a' binding is only used in the ephemeral
-;; `consequent' clause of the first `if', but its index would be
-;; reserved for the whole of the `or' expansion. So we have a hack for
-;; this specific case. A proper solution would be some sort of liveness
-;; analysis, and not our linear allocation algorithm.
-;;
-;; Closure variables are captured when a closure is created, and stored in a
-;; vector inline to the closure object itself. Each closure variable has a
-;; unique index into that vector.
-;;
-;; There is one more complication. Procedures bound by <fix> may, in
-;; some cases, be rendered inline to their parent procedure. That is to
-;; say,
-;;
-;;  (letrec ((lp (lambda () (lp)))) (lp))
-;;    => (fix ((lp (lambda () (lp)))) (lp))
-;;      => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
-;;         ^ jump over the loop  ^ the fixpoint lp ^ starting off the loop
-;;
-;; The upshot is that we don't have to allocate any space for the `lp'
-;; closure at all, as it can be rendered inline as a loop. So there is
-;; another kind of allocation, "label allocation", in which the
-;; procedure is simply a label, placed at the start of the lambda body.
-;; The label is the gensym under which the lambda expression is bound.
-;;
-;; The analyzer checks to see that the label is called with the correct
-;; number of arguments. Calls to labels compile to rename + goto.
-;; Lambda, the ultimate goto!
-;;
-;;
-;; The return value of `analyze-lexicals' is a hash table, the
-;; "allocation".
-;;
-;; The allocation maps gensyms -- recall that each lexically bound
-;; variable has a unique gensym -- to storage locations ("addresses").
-;; Since one gensym may have many storage locations, if it is referenced
-;; in many procedures, it is a two-level map.
-;;
-;; The allocation also stored information on how many local variables
-;; need to be allocated for each procedure, lexicals that have been
-;; translated into labels, and information on what free variables to
-;; capture from its lexical parent procedure.
-;;
-;; In addition, we have a conflation: while we're traversing the code,
-;; recording information to pass to the compiler, we take the
-;; opportunity to generate labels for each lambda-case clause, so that
-;; generated code can skip argument checks at runtime if they match at
-;; compile-time.
-;;
-;; Also, while we're a-traversing and an-allocating, we check prompt
-;; handlers to see if the "continuation" argument is used. If not, we
-;; mark the prompt as being "escape-only". This allows us to implement
-;; `catch' and `throw' using `prompt' and `control', but without causing
-;; a continuation to be reified. Heh heh.
-;;
-;; That is:
-;;
-;;  sym -> {lambda -> address}
-;;  lambda -> (labels . free-locs)
-;;  lambda-case -> (gensym . nlocs)
-;;  prompt -> escape-only?
-;;
-;; address ::= (local? boxed? . index)
-;; labels ::= ((sym . lambda) ...)
-;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
-;; free variable addresses are relative to parent proc.
-
-(define (make-hashq k v)
-  (let ((res (make-hash-table)))
-    (hashq-set! res k v)
-    res))
-
-(define (analyze-lexicals x)
-  ;; bound-vars: lambda -> (sym ...)
-  ;;  all identifiers bound within a lambda
-  (define bound-vars (make-hash-table))
-  ;; free-vars: lambda -> (sym ...)
-  ;;  all identifiers referenced in a lambda, but not bound
-  ;;  NB, this includes identifiers referenced by contained lambdas
-  (define free-vars (make-hash-table))
-  ;; assigned: sym -> #t
-  ;;  variables that are assigned
-  (define assigned (make-hash-table))
-  ;; refcounts: sym -> count
-  ;;  allows us to detect the or-expansion in O(1) time
-  (define refcounts (make-hash-table))
-  ;; labels: sym -> lambda
-  ;;  for determining if fixed-point procedures can be rendered as
-  ;;  labels.
-  (define labels (make-hash-table))
-
-  ;; returns variables referenced in expr
-  (define (analyze! x proc labels-in-proc tail? tail-call-args)
-    (define (step y) (analyze! y proc '() #f #f))
-    (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
-    (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
-                                              (and tail? args)))
-    (define (recur/labels x new-proc labels)
-      (analyze! x new-proc (append labels labels-in-proc) #t #f))
-    (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
-    (record-case x
-      ((<call> proc args)
-       (apply lset-union eq? (step-tail-call proc args)
-              (map step args)))
-
-      ((<primcall> args)
-       (apply lset-union eq? (map step args)))
-
-      ((<conditional> test consequent alternate)
-       (lset-union eq? (step test) (step-tail consequent) (step-tail 
alternate)))
-
-      ((<lexical-ref> gensym)
-       (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
-       (if (not (and tail-call-args
-                     (memq gensym labels-in-proc)
-                     (let ((p (hashq-ref labels gensym)))
-                       (and p
-                            (let lp ((c (lambda-body p)))
-                              (and c (lambda-case? c)
-                                   (or 
-                                    ;; for now prohibit optional &
-                                    ;; keyword arguments; can relax this
-                                    ;; restriction later
-                                    (and (= (length (lambda-case-req c))
-                                            (length tail-call-args))
-                                         (not (lambda-case-opt c))
-                                         (not (lambda-case-kw c))
-                                         (not (lambda-case-rest c)))
-                                    (lp (lambda-case-alternate c)))))))))
-           (hashq-set! labels gensym #f))
-       (list gensym))
-      
-      ((<lexical-set> gensym exp)
-       (hashq-set! assigned gensym #t)
-       (hashq-set! labels gensym #f)
-       (lset-adjoin eq? (step exp) gensym))
-      
-      ((<module-set> exp)
-       (step exp))
-      
-      ((<toplevel-set> exp)
-       (step exp))
-      
-      ((<toplevel-define> exp)
-       (step exp))
-      
-      ((<seq> head tail)
-       (lset-union eq? (step head) (step-tail tail)))
-      
-      ((<lambda> body)
-       ;; order is important here
-       (hashq-set! bound-vars x '())
-       (let ((free (recur body x)))
-         (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
-         (hashq-set! free-vars x free)
-         free))
-      
-      ((<lambda-case> opt kw inits gensyms body alternate)
-       (hashq-set! bound-vars proc
-                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
-       (lset-union
-        eq?
-        (lset-difference eq?
-                         (lset-union eq?
-                                     (apply lset-union eq? (map step inits))
-                                     (step-tail body))
-                         gensyms)
-        (if alternate (step-tail alternate) '())))
-      
-      ((<let> gensyms vals body)
-       (hashq-set! bound-vars proc
-                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
-       (lset-difference eq?
-                        (apply lset-union eq? (step-tail body) (map step vals))
-                        gensyms))
-      
-      ((<letrec> gensyms vals body)
-       (hashq-set! bound-vars proc
-                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
-       (for-each (lambda (sym) (hashq-set! assigned sym #t)) gensyms)
-       (lset-difference eq?
-                        (apply lset-union eq? (step-tail body) (map step vals))
-                        gensyms))
-      
-      ((<fix> gensyms vals body)
-       ;; Try to allocate these procedures as labels.
-       (for-each (lambda (sym val) (hashq-set! labels sym val))
-                 gensyms vals)
-       (hashq-set! bound-vars proc
-                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
-       ;; Step into subexpressions.
-       (let* ((var-refs
-               (map
-                ;; Since we're trying to label-allocate the lambda,
-                ;; pretend it's not a closure, and just recurse into its
-                ;; body directly. (Otherwise, recursing on a closure
-                ;; that references one of the fix's bound vars would
-                ;; prevent label allocation.)
-                (lambda (x)
-                  (record-case x
-                    ((<lambda> body)
-                     ;; just like the closure case, except here we use
-                     ;; recur/labels instead of recur
-                     (hashq-set! bound-vars x '())
-                     (let ((free (recur/labels body x gensyms)))
-                       (hashq-set! bound-vars x (reverse! (hashq-ref 
bound-vars x)))
-                       (hashq-set! free-vars x free)
-                       free))))
-                vals))
-              (vars-with-refs (map cons gensyms var-refs))
-              (body-refs (recur/labels body proc gensyms)))
-         (define (delabel-dependents! sym)
-           (let ((refs (assq-ref vars-with-refs sym)))
-             (if refs
-                 (for-each (lambda (sym)
-                             (if (hashq-ref labels sym)
-                                 (begin
-                                   (hashq-set! labels sym #f)
-                                   (delabel-dependents! sym))))
-                           refs))))
-         ;; Stepping into the lambdas and the body might have made some
-         ;; procedures not label-allocatable -- which might have
-         ;; knock-on effects. For example:
-         ;;   (fix ((a (lambda () (b)))
-         ;;         (b (lambda () a)))
-         ;;     (a))
-         ;; As far as `a' is concerned, both `a' and `b' are
-         ;; label-allocatable. But `b' references `a' not in a proc-tail
-         ;; position, which makes `a' not label-allocatable. The
-         ;; knock-on effect is that, when back-propagating this
-         ;; information to `a', `b' will also become not
-         ;; label-allocatable, as it is referenced within `a', which is
-         ;; allocated as a closure. This is a transitive relationship.
-         (for-each (lambda (sym)
-                     (if (not (hashq-ref labels sym))
-                         (delabel-dependents! sym)))
-                   gensyms)
-         ;; Now lift bound variables with label-allocated lambdas to the
-         ;; parent procedure.
-         (for-each
-          (lambda (sym val)
-            (if (hashq-ref labels sym)
-                ;; Remove traces of the label-bound lambda. The free
-                ;; vars will propagate up via the return val.
-                (begin
-                  (hashq-set! bound-vars proc
-                              (append (hashq-ref bound-vars val)
-                                      (hashq-ref bound-vars proc)))
-                  (hashq-remove! bound-vars val)
-                  (hashq-remove! free-vars val))))
-          gensyms vals)
-         (lset-difference eq?
-                          (apply lset-union eq? body-refs var-refs)
-                          gensyms)))
-      
-      ((<let-values> exp body)
-       (lset-union eq? (step exp) (step body)))
-      
-      ((<prompt> escape-only? tag body handler)
-       (match handler
-         (($ <lambda> _ _ handler)
-          (lset-union eq? (step tag) (step body) (step-tail handler)))))
-      
-      ((<abort> tag args tail)
-       (apply lset-union eq? (step tag) (step tail) (map step args)))
-      
-      (else '())))
-  
-  ;; allocation: sym -> {lambda -> address}
-  ;;             lambda -> (labels . free-locs)
-  ;;             lambda-case -> (gensym . nlocs)
-  (define allocation (make-hash-table))
-  
-  (define (allocate! x proc n)
-    (define (recur y) (allocate! y proc n))
-    (record-case x
-      ((<call> proc args)
-       (apply max (recur proc) (map recur args)))
-
-      ((<primcall> args)
-       (apply max n (map recur args)))
-
-      ((<conditional> test consequent alternate)
-       (max (recur test) (recur consequent) (recur alternate)))
-
-      ((<lexical-set> exp)
-       (recur exp))
-      
-      ((<module-set> exp)
-       (recur exp))
-      
-      ((<toplevel-set> exp)
-       (recur exp))
-      
-      ((<toplevel-define> exp)
-       (recur exp))
-      
-      ((<seq> head tail)
-       (max (recur head)
-            (recur tail)))
-      
-      ((<lambda> body)
-       ;; allocate closure vars in order
-       (let lp ((c (hashq-ref free-vars x)) (n 0))
-         (if (pair? c)
-             (begin
-               (hashq-set! (hashq-ref allocation (car c))
-                           x
-                           `(#f ,(hashq-ref assigned (car c)) . ,n))
-               (lp (cdr c) (1+ n)))))
-      
-       (let ((nlocs (allocate! body x 0))
-             (free-addresses
-              (map (lambda (v)
-                     (hashq-ref (hashq-ref allocation v) proc))
-                   (hashq-ref free-vars x)))
-             (labels (filter cdr
-                             (map (lambda (sym)
-                                    (cons sym (hashq-ref labels sym)))
-                                  (hashq-ref bound-vars x)))))
-         ;; set procedure allocations
-         (hashq-set! allocation x (cons labels free-addresses)))
-       n)
-
-      ((<lambda-case> opt kw inits gensyms body alternate)
-       (max
-        (let lp ((gensyms gensyms) (n n))
-          (if (null? gensyms)
-              (let ((nlocs (apply
-                            max
-                            (allocate! body proc n)
-                            ;; inits not logically at the end, but they
-                            ;; are the list...
-                            (map (lambda (x) (allocate! x proc n)) inits))))
-                ;; label and nlocs for the case
-                (hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
-                nlocs)
-              (begin
-                (hashq-set! allocation (car gensyms)
-                            (make-hashq
-                             proc `(#t ,(hashq-ref assigned (car gensyms)) . 
,n)))
-                (lp (cdr gensyms) (1+ n)))))
-        (if alternate (allocate! alternate proc n) n)))
-      
-      ((<let> gensyms vals body)
-       (let ((nmax (apply max (map recur vals))))
-         (cond
-          ;; the `or' hack
-          ((and (conditional? body)
-                (= (length gensyms) 1)
-                (let ((v (car gensyms)))
-                  (and (not (hashq-ref assigned v))
-                       (= (hashq-ref refcounts v 0) 2)
-                       (lexical-ref? (conditional-test body))
-                       (eq? (lexical-ref-gensym (conditional-test body)) v)
-                       (lexical-ref? (conditional-consequent body))
-                       (eq? (lexical-ref-gensym (conditional-consequent body)) 
v))))
-           (hashq-set! allocation (car gensyms)
-                       (make-hashq proc `(#t #f . ,n)))
-           ;; the 1+ for this var
-           (max nmax (1+ n) (allocate! (conditional-alternate body) proc n)))
-          (else
-           (let lp ((gensyms gensyms) (n n))
-             (if (null? gensyms)
-                 (max nmax (allocate! body proc n))
-                 (let ((v (car gensyms)))
-                   (hashq-set!
-                    allocation v
-                    (make-hashq proc
-                                `(#t ,(hashq-ref assigned v) . ,n)))
-                   (lp (cdr gensyms) (1+ n)))))))))
-      
-      ((<letrec> gensyms vals body)
-       (let lp ((gensyms gensyms) (n n))
-         (if (null? gensyms)
-             (let ((nmax (apply max
-                                (map (lambda (x)
-                                       (allocate! x proc n))
-                                     vals))))
-               (max nmax (allocate! body proc n)))
-             (let ((v (car gensyms)))
-               (hashq-set!
-                allocation v
-                (make-hashq proc
-                            `(#t ,(hashq-ref assigned v) . ,n)))
-               (lp (cdr gensyms) (1+ n))))))
-
-      ((<fix> gensyms vals body)
-       (let lp ((in gensyms) (n n))
-         (if (null? in)
-             (let lp ((gensyms gensyms) (vals vals) (nmax n))
-               (cond
-                ((null? gensyms)
-                 (max nmax (allocate! body proc n)))
-                ((hashq-ref labels (car gensyms))                 
-                 ;; allocate lambda body inline to proc
-                 (lp (cdr gensyms)
-                     (cdr vals)
-                     (record-case (car vals)
-                       ((<lambda> body)
-                        (max nmax (allocate! body proc n))))))
-                (else
-                 ;; allocate closure
-                 (lp (cdr gensyms)
-                     (cdr vals)
-                     (max nmax (allocate! (car vals) proc n))))))
-             
-             (let ((v (car in)))
-               (cond
-                ((hashq-ref assigned v)
-                 (error "fixpoint procedures may not be assigned" x))
-                ((hashq-ref labels v)
-                 ;; no binding, it's a label
-                 (lp (cdr in) n))
-                (else
-                 ;; allocate closure binding
-                 (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
-                 (lp (cdr in) (1+ n))))))))
-
-      ((<let-values> exp body)
-       (max (recur exp) (recur body)))
-      
-      ((<prompt> escape-only? tag body handler)
-       (match handler
-         (($ <lambda> _ _ handler)
-          (max (recur tag) (recur body) (recur handler)))))
-
-      ((<abort> tag args tail)
-       (apply max (recur tag) (recur tail) (map recur args)))
-      
-      (else n)))
-
-  (analyze! x #f '() #t #f)
-  (allocate! x #f 0)
-
-  allocation)
-
-
 ;;;
 ;;; Tree analyses for warnings.
 ;;;