[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 05/05: Remove unused analyze-lexicals function
From: |
Andy Wingo |
Subject: |
[Guile-commits] 05/05: Remove unused analyze-lexicals function |
Date: |
Wed, 29 Apr 2020 05:14:42 -0400 (EDT) |
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.
;;;
- [Guile-commits] branch master updated (1fbe89f -> 3d96c87), Andy Wingo, 2020/04/29
- [Guile-commits] 01/05: bitvector-count-bits replaces bit-count*, Andy Wingo, 2020/04/29
- [Guile-commits] 03/05: Prefer C-like interfaces for scm_c_bitvector_{set, clear}_bits_x, Andy Wingo, 2020/04/29
- [Guile-commits] 02/05: Deprecate useless C bitvector interface, Andy Wingo, 2020/04/29
- [Guile-commits] 04/05: Deprecate scm_bitvector, scm_make_bitvector, scm_bitvector_p, Andy Wingo, 2020/04/29
- [Guile-commits] 05/05: Remove unused analyze-lexicals function,
Andy Wingo <=