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