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 ;; allocation:
  38 ;;  sym -> (local . index) | (heap level . index)
  39 ;;  lambda -> (nlocs . nexts)
  40
  41 (define (analyze-lexicals x)
  42   ;; parents: lambda -> parent
  43   ;;  useful when we see a closed-over var, so we can calculate its
  44   ;;  coordinates (depth and index).
  45   ;; bindings: lambda -> (sym ...)
  46   ;;  useful for two reasons: one, so we know how much space to allocate
  47   ;;  when we go into a lambda; and two, so that we know when to stop,
  48   ;;  when looking for closed-over vars.
  49   ;; heaps: sym -> lambda
  50   ;;  allows us to heapify vars in an O(1) fashion
  51
  52   (define (find-heap sym parent)
  53     ;; fixme: check displaced lexicals here?
  54     (if (memq sym (hashq-ref bindings parent))
  55         parent
  56         (find-heap sym (hashq-ref parents parent))))
  57
  58   (define (analyze! x parent level)
  59     (define (step y) (analyze! y parent level))
  60     (define (recur x parent) (analyze! x parent (1+ level)))
  61     (record-case x
  62       ((<application> proc args)
  63        (step proc) (for-each step args))
  64
  65       ((<conditional> test then else)
  66        (step test) (step then) (step else))
  67
  68       ((<lexical-ref> name gensym)
  69        (if (and (not (memq gensym (hashq-ref bindings parent)))
  70                 (not (hashq-ref heaps gensym)))
  71            (hashq-set! heaps gensym (find-heap gensym parent))))
  72
  73       ((<lexical-set> name gensym exp)
  74        (step exp)
  75        (if (not (hashq-ref heaps gensym))
  76            (hashq-set! heaps gensym (find-heap gensym parent))))
  77
  78       ((<module-set> mod name public? exp)
  79        (step exp))
  80
  81       ((<toplevel-set> name exp)
  82        (step exp))
  83
  84       ((<toplevel-define> name exp)
  85        (step exp))
  86
  87       ((<sequence> exps)
  88        (for-each step exps))
  89
  90       ((<lambda> vars meta body)
  91        (hashq-set! parents x parent)
  92        (hashq-set! bindings x
  93                    (let rev* ((vars vars) (out '()))
  94                      (cond ((null? vars) out)
  95                            ((pair? vars) (rev* (cdr vars)
  96                                                (cons (car vars) out)))
  97                            (else (cons vars out)))))
  98        (recur body x)
  99        (hashq-set! bindings x (reverse! (hashq-ref bindings x))))
 100
 101       ((<let> vars vals exp)
 102        (for-each step vals)
 103        (hashq-set! bindings parent
 104                    (append (reverse vars) (hashq-ref bindings parent)))
 105        (step exp))
 106
 107       ((<letrec> vars vals exp)
 108        (hashq-set! bindings parent
 109                    (append (reverse vars) (hashq-ref bindings parent)))
 110        (for-each step vals)
 111        (step exp))
 112
 113       (else #f)))
 114
 115     (define (allocate-heap! binder)
 116       (hashq-set! heap-indexes binder
 117                   (1+ (hashq-ref heap-indexes binder -1))))
 118
 119     (define (allocate! x level n)
 120       (define (recur y) (allocate! y level n))
 121       (record-case x
 122         ((<application> proc args)
 123          (apply max (recur proc) (map recur args)))
 124
 125         ((<conditional> test then else)
 126          (max (recur test) (recur then) (recur else)))
 127
 128         ((<lexical-set> name gensym exp)
 129          (recur exp))
 130
 131         ((<module-set> mod name public? exp)
 132          (recur exp))
 133
 134         ((<toplevel-set> name exp)
 135          (recur exp))
 136
 137         ((<toplevel-define> name exp)
 138          (recur exp))
 139
 140         ((<sequence> exps)
 141          (apply max (map recur exps)))
 142
 143         ((<lambda> vars meta body)
 144          (let lp ((vars vars) (n 0))
 145            (if (null? vars)
 146                (hashq-set! allocation x
 147                            (let ((nlocs (allocate! body (1+ level) n)))
 148                              (cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
 149                (let ((v (if (pair? vars) (car vars) vars)))
 150                  (let ((binder (hashq-ref heaps v)))
 151                    (hashq-set!
 152                     allocation v
 153                     (if binder
 154                         (cons* 'heap (1+ level) (allocate-heap! binder))
 155                         (cons 'stack n))))
 156                  (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
 157          n)
 158
 159         ((<let> vars vals exp)
 160          (let ((nmax (apply max (map recur vals))))
 161            (let lp ((vars vars) (n n))
 162              (if (null? vars)
 163                  (max nmax (allocate! exp level n))
 164                  (let ((v (car vars)))
 165                    (let ((binder (hashq-ref heaps v)))
 166                      (hashq-set!
 167                       allocation v
 168                       (if binder
 169                           (cons* 'heap level (allocate-heap! binder))
 170                           (cons 'stack n))))
 171                    (lp (cdr vars) (1+ n)))))))
 172
 173         ((<letrec> vars vals exp)
 174          (let lp ((vars vars) (n n))
 175            (if (null? vars)
 176                (let ((nmax (apply max
 177                                   (map (lambda (x)
 178                                          (allocate! x level n))
 179                                        vals))))
 180                  (max nmax (allocate! exp level n)))
 181                (let ((v (car vars)))
 182                  (let ((binder (hashq-ref heaps v)))
 183                    (hashq-set!
 184                     allocation v
 185                     (if binder
 186                         (cons* 'heap level (allocate-heap! binder))
 187                         (cons 'stack n))))
 188                  (lp (cdr vars) (1+ n))))))
 189
 190         (else n)))
 191
 192   (define parents (make-hash-table))
 193   (define bindings (make-hash-table))
 194   (define heaps (make-hash-table))
 195   (define allocation (make-hash-table))
 196   (define heap-indexes (make-hash-table))
 197
 198   (analyze! x #f -1)
 199   (allocate! x -1 0)
 200
 201   allocation)