module/language/tree-il/analyze.scm

   1 ;;; TREE-IL -> GLIL compiler
   2
   3 ;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language tree-il analyze)
  22   #:use-module (system base syntax)
  23   #:use-module (language tree-il)
  24   #:export (analyze-lexicals))
  25
  26 ;; allocation: the process of assigning a type and index to each var
  27 ;; a var is external if it is heaps; assigning index is easy
  28 ;; args are assigned in order
  29 ;; locals are indexed as their linear position in the binding path
  30 ;; (let (0 1)
  31 ;;   (let (2 3) ...)
  32 ;;   (let (2) ...))
  33 ;;   (let (2 3 4) ...))
  34 ;; etc.
  35 ;;
  36 ;; This algorithm has the problem that variables are only allocated
  37 ;; indices at the end of the binding path. If variables bound early in
  38 ;; the path are not used in later portions of the path, their indices
  39 ;; will not be recycled. This problem is particularly egregious in the
  40 ;; expansion of `or':
  41 ;;
  42 ;;  (or x y z)
  43 ;;    -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
  44 ;;
  45 ;; As you can see, the `a' binding is only used in the ephemeral `then'
  46 ;; clause of the first `if', but its index would be reserved for the
  47 ;; whole of the `or' expansion. So we have a hack for this specific
  48 ;; case. A proper solution would be some sort of liveness analysis, and
  49 ;; not our linear allocation algorithm.
  50 ;;
  51 ;; allocation:
  52 ;;  sym -> (local . index) | (heap level . index)
  53 ;;  lambda -> (nlocs . nexts)
  54
  55 (define (analyze-lexicals x)
  56   ;; parents: lambda -> parent
  57   ;;  useful when we see a closed-over var, so we can calculate its
  58   ;;  coordinates (depth and index).
  59   ;; bindings: lambda -> (sym ...)
  60   ;;  useful for two reasons: one, so we know how much space to allocate
  61   ;;  when we go into a lambda; and two, so that we know when to stop,
  62   ;;  when looking for closed-over vars.
  63   ;; heaps: sym -> lambda
  64   ;;  allows us to heapify vars in an O(1) fashion
  65   ;; refcounts: sym -> count
  66   ;;  allows us to detect the or-expansion an O(1) time
  67
  68   (define (find-heap sym parent)
  69     ;; fixme: check displaced lexicals here?
  70     (if (memq sym (hashq-ref bindings parent))
  71         parent
  72         (find-heap sym (hashq-ref parents parent))))
  73
  74   (define (analyze! x parent level)
  75     (define (step y) (analyze! y parent level))
  76     (define (recur x parent) (analyze! x parent (1+ level)))
  77     (record-case x
  78       ((<application> proc args)
  79        (step proc) (for-each step args))
  80
  81       ((<conditional> test then else)
  82        (step test) (step then) (step else))
  83
  84       ((<lexical-ref> name gensym)
  85        (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
  86        (if (and (not (memq gensym (hashq-ref bindings parent)))
  87                 (not (hashq-ref heaps gensym)))
  88            (hashq-set! heaps gensym (find-heap gensym parent))))
  89
  90       ((<lexical-set> name gensym exp)
  91        (step exp)
  92        (if (not (hashq-ref heaps gensym))
  93            (hashq-set! heaps gensym (find-heap gensym parent))))
  94
  95       ((<module-set> mod name public? exp)
  96        (step exp))
  97
  98       ((<toplevel-set> name exp)
  99        (step exp))
 100
 101       ((<toplevel-define> name exp)
 102        (step exp))
 103
 104       ((<sequence> exps)
 105        (for-each step exps))
 106
 107       ((<lambda> vars meta body)
 108        (hashq-set! parents x parent)
 109        (hashq-set! bindings x
 110                    (let rev* ((vars vars) (out '()))
 111                      (cond ((null? vars) out)
 112                            ((pair? vars) (rev* (cdr vars)
 113                                                (cons (car vars) out)))
 114                            (else (cons vars out)))))
 115        (recur body x)
 116        (hashq-set! bindings x (reverse! (hashq-ref bindings x))))
 117
 118       ((<let> vars vals body)
 119        (for-each step vals)
 120        (hashq-set! bindings parent
 121                    (append (reverse vars) (hashq-ref bindings parent)))
 122        (step body))
 123
 124       ((<letrec> vars vals body)
 125        (hashq-set! bindings parent
 126                    (append (reverse vars) (hashq-ref bindings parent)))
 127        (for-each step vals)
 128        (step body))
 129
 130       ((<let-values> vars exp body)
 131        (hashq-set! bindings parent
 132                    (let lp ((out (hashq-ref bindings parent)) (in vars))
 133                      (if (pair? in)
 134                          (lp (cons (car in) out) (cdr in))
 135                          (if (null? in) out (cons in out)))))
 136        (step exp)
 137        (step body))
 138
 139       (else #f)))
 140
 141     (define (allocate-heap! binder)
 142       (hashq-set! heap-indexes binder
 143                   (1+ (hashq-ref heap-indexes binder -1))))
 144
 145     (define (allocate! x level n)
 146       (define (recur y) (allocate! y level n))
 147       (record-case x
 148         ((<application> proc args)
 149          (apply max (recur proc) (map recur args)))
 150
 151         ((<conditional> test then else)
 152          (max (recur test) (recur then) (recur else)))
 153
 154         ((<lexical-set> name gensym exp)
 155          (recur exp))
 156
 157         ((<module-set> mod name public? exp)
 158          (recur exp))
 159
 160         ((<toplevel-set> name exp)
 161          (recur exp))
 162
 163         ((<toplevel-define> name exp)
 164          (recur exp))
 165
 166         ((<sequence> exps)
 167          (apply max (map recur exps)))
 168
 169         ((<lambda> vars meta body)
 170          (let lp ((vars vars) (n 0))
 171            (if (null? vars)
 172                (hashq-set! allocation x
 173                            (let ((nlocs (- (allocate! body (1+ level) n) n)))
 174                              (cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
 175                (let ((v (if (pair? vars) (car vars) vars)))
 176                  (let ((binder (hashq-ref heaps v)))
 177                    (hashq-set!
 178                     allocation v
 179                     (if binder
 180                         (cons* 'heap (1+ level) (allocate-heap! binder))
 181                         (cons 'stack n))))
 182                  (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
 183          n)
 184
 185         ((<let> vars vals body)
 186          (let ((nmax (apply max (map recur vals))))
 187            (cond
 188             ;; the `or' hack
 189             ((and (conditional? body)
 190                   (= (length vars) 1)
 191                   (let ((v (car vars)))
 192                     (and (not (hashq-ref heaps v))
 193                          (= (hashq-ref refcounts v 0) 2)
 194                          (lexical-ref? (conditional-test body))
 195                          (eq? (lexical-ref-gensym (conditional-test body)) v)
 196                          (lexical-ref? (conditional-then body))
 197                          (eq? (lexical-ref-gensym (conditional-then body)) v))))
 198              (hashq-set! allocation (car vars) (cons 'stack n))
 199              ;; the 1+ for this var
 200              (max nmax (1+ n) (allocate! (conditional-else body) level n)))
 201             (else
 202              (let lp ((vars vars) (n n))
 203                (if (null? vars)
 204                    (max nmax (allocate! body level n))
 205                    (let ((v (car vars)))
 206                      (let ((binder (hashq-ref heaps v)))
 207                        (hashq-set!
 208                         allocation v
 209                         (if binder
 210                             (cons* 'heap level (allocate-heap! binder))
 211                             (cons 'stack n)))
 212                        (lp (cdr vars) (if binder n (1+ n)))))))))))
 213
 214         ((<letrec> vars vals body)
 215          (let lp ((vars vars) (n n))
 216            (if (null? vars)
 217                (let ((nmax (apply max
 218                                   (map (lambda (x)
 219                                          (allocate! x level n))
 220                                        vals))))
 221                  (max nmax (allocate! body level n)))
 222                (let ((v (car vars)))
 223                  (let ((binder (hashq-ref heaps v)))
 224                    (hashq-set!
 225                     allocation v
 226                     (if binder
 227                         (cons* 'heap level (allocate-heap! binder))
 228                         (cons 'stack n)))
 229                    (lp (cdr vars) (if binder n (1+ n))))))))
 230
 231         ((<let-values> vars exp body)
 232          (let ((nmax (recur exp)))
 233            (let lp ((vars vars) (n n))
 234              (if (null? vars)
 235                  (max nmax (allocate! body level n))
 236                  (let ((v (if (pair? vars) (car vars) vars)))
 237                    (let ((binder (hashq-ref heaps v)))
 238                      (hashq-set!
 239                       allocation v
 240                       (if binder
 241                           (cons* 'heap level (allocate-heap! binder))
 242                           (cons 'stack n)))
 243                      (lp (if (pair? vars) (cdr vars) '())
 244                          (if binder n (1+ n)))))))))
 245
 246         (else n)))
 247
 248   (define parents (make-hash-table))
 249   (define bindings (make-hash-table))
 250   (define heaps (make-hash-table))
 251   (define refcounts (make-hash-table))
 252   (define allocation (make-hash-table))
 253   (define heap-indexes (make-hash-table))
 254
 255   (analyze! x #f -1)
 256   (allocate! x -1 0)
 257
 258   allocation)