1;;; transformation of top-level bindings into letrec* 2 3;; Copyright (C) 2019-2020 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(define-module (language tree-il letrectify) 20 #:use-module ((srfi srfi-1) #:select (fold-right)) 21 #:use-module (srfi srfi-11) 22 #:use-module (ice-9 match) 23 #:use-module (language tree-il) 24 #:use-module (language tree-il effects) 25 #:export (letrectify)) 26 27;; Take a sequence of top-level definitions and turn the defintions into 28;; letrec*. From this: 29;; 30;; (begin 31;; (define a 10) 32;; (define b (lambda () a)) 33;; (foo a) 34;; (define c (lambda () (set! c b) (c)))) 35;; 36;; To this: 37;; 38;; (letrec* ((a-var (module-make-local-var! (current-module) 'a)) 39;; (a 10) 40;; (_ (begin (variable-set! a-var a))) 41;; (b-var (module-make-local-var! (current-module) 'b)) 42;; (b (lambda () a)) 43;; (_ (begin (variable-set! b-var b))) 44;; (_ (begin (foo a) #t)) 45;; (c-var (module-make-local-var! (current-module) 'c))) 46;; (c (lambda () (variable-set! c-var b) ((variable-ref c-var)))) 47;; (_ (begin (variable-set! c-var c)))) 48;; (void)) 49;; 50;; Inside the compilation unit, references to "declarative" top-level 51;; definitions are accessed directly as lexicals. A declarative 52;; definition is a variable for which the expander knows the module, 53;; which is defined in the compilation unit exactly one time, and which 54;; is not assigned in the compilation unit. 55;; 56;; The assumption is that it's safe for the compiler to reason about the 57;; *values* of declarative bindings, because they are immutable in 58;; practice. Of course someone can come later from another compilation 59;; unit or another module and use the private module API to mutate 60;; definitions from this compilation unit; in that case, updates from 61;; that third party may not be visible to users of declarative 62;; definitions. That kind of use is not common, though. The letrectify 63;; transformation is so important for performance that most users are 64;; willing to accept the restrictions of this transformation. 65;; 66;; Incidentally, the later fix-letrec and peval passes should optimize 67;; the above example to: 68;; 69;; (begin 70;; (variable-set! (module-make-local-var! (current-module) 'a) 10) 71;; (variable-set! (module-make-local-var! (current-module) 'b) 72;; (lambda () 10)) 73;; (foo 10) 74;; (let ((c-var (module-make-local-var! (current-module) 'c))) 75;; (variable-set! c-var 76;; (lambda () 77;; (variable-set! c-var (lambda () 10)) 78;; ((variable-ref c-var)))) 79;; (void))) 80;; 81;; As you can see, letrectification allowed for inlining of the uses of 82;; both A and B. 83;; 84 85(define for-each-fold (make-tree-il-folder)) 86(define (tree-il-for-each f x) 87 (for-each-fold x (lambda (x) (f x) (values)) (lambda (x) (values)))) 88 89(define (compute-declarative-toplevels x) 90 (define dynamic (make-hash-table)) 91 (define defined (make-hash-table)) 92 (define assigned (make-hash-table)) 93 (tree-il-for-each 94 (lambda (x) 95 (match x 96 (($ <toplevel-set> src mod name) 97 (if mod 98 (hash-set! assigned (cons mod name) #t) 99 (hashq-set! dynamic name #t))) 100 (($ <toplevel-define> src mod name expr) 101 (if mod 102 (hash-set! (if (hash-ref defined (cons mod name)) 103 assigned 104 defined) 105 (cons mod name) expr) 106 (hashq-set! dynamic name #t))) 107 (_ (values)))) 108 x) 109 (let ((declarative (make-hash-table))) 110 (define (declarative-module? mod) 111 (let ((m (resolve-module mod #f #:ensure #f))) 112 (and m (module-declarative? m)))) 113 (hash-for-each (lambda (k expr) 114 (match k 115 ((mod . name) 116 (unless (or (hash-ref assigned k) 117 (hashq-ref dynamic name) 118 (not (declarative-module? mod))) 119 (hash-set! declarative k expr))))) 120 defined) 121 declarative)) 122 123(define (compute-private-toplevels declarative) 124 ;; Set of variables exported by the modules of declarative bindings in 125 ;; this compilation unit. 126 (define exports (make-hash-table)) 127 ;; If a module exports a macro, that macro could implicitly export any 128 ;; top-level binding in a module; we have to avoid sealing private 129 ;; bindings in that case. 130 (define exports-macro? (make-hash-table)) 131 (hash-for-each 132 (lambda (k _) 133 (match k 134 ((mod . name) 135 (unless (hash-get-handle exports-macro? mod) 136 (hash-set! exports-macro? mod #f) 137 (let ((i (module-public-interface (resolve-module mod)))) 138 (when i 139 (module-for-each 140 (lambda (k v) 141 (hashq-set! exports v k) 142 (when (and (variable-bound? v) (macro? (variable-ref v))) 143 (hash-set! exports-macro? mod #t))) 144 i))))))) 145 declarative) 146 (let ((private (make-hash-table))) 147 (hash-for-each 148 (lambda (k _) 149 (match k 150 ((mod . name) 151 (unless (or (hash-ref exports-macro? mod) 152 (hashq-ref exports 153 (module-local-variable (resolve-module mod) name))) 154 (hash-set! private k #t))))) 155 declarative) 156 private)) 157 158(define* (letrectify expr #:key (seal-private-bindings? #f)) 159 (define declarative (compute-declarative-toplevels expr)) 160 (define private 161 (if seal-private-bindings? 162 (compute-private-toplevels declarative) 163 (make-hash-table))) 164 (define declarative-box+value 165 (let ((tab (make-hash-table))) 166 (hash-for-each (lambda (key val) 167 (let ((box (and (not (hash-ref private key)) 168 (gensym))) 169 (val (gensym))) 170 (hash-set! tab key (cons box val)))) 171 declarative) 172 (lambda (mod name) 173 (hash-ref tab (cons mod name))))) 174 175 (define compute-effects 176 ;; Assume all lexicals are assigned, for the purposes of this 177 ;; transformation. (It doesn't matter.) 178 (let ((assigned? (lambda (sym) #t))) 179 (make-effects-analyzer assigned?))) 180 181 (define (can-elide-statement? stmt) 182 (let ((effects (compute-effects stmt))) 183 (effect-free? 184 (exclude-effects effects (logior &allocation &zero-values))))) 185 186 (define (add-binding name var val tail) 187 (match tail 188 (($ <letrec> src #t names vars vals tail) 189 (make-letrec src #t 190 (cons name names) (cons var vars) (cons val vals) 191 tail)) 192 (_ 193 (make-letrec (tree-il-src tail) #t 194 (list name) (list var) (list val) 195 tail)))) 196 197 (define (add-statement src stmt tail) 198 (if (can-elide-statement? stmt) 199 tail 200 (add-binding '_ (gensym "_") (make-seq src stmt (make-void src)) 201 tail))) 202 203 (define (visit-expr expr) 204 (post-order 205 (lambda (expr) 206 (match expr 207 (($ <toplevel-ref> src mod name) 208 (match (declarative-box+value mod name) 209 (#f expr) 210 ((box . value) 211 (make-lexical-ref src name value)))) 212 (_ expr))) 213 expr)) 214 215 (define (visit-top-level expr mod-vars) 216 (match expr 217 (($ <toplevel-define> src mod name exp) 218 (match (declarative-box+value mod name) 219 (#f (values (visit-expr expr) mod-vars)) 220 ((#f . value) 221 (values (add-binding name value (visit-expr exp) (make-void src)) 222 mod-vars)) 223 ((box . value) 224 (match (assoc-ref mod-vars mod) 225 (#f 226 (let* ((mod-var (gensym "mod")) 227 (mod-vars (acons mod mod-var mod-vars))) 228 (call-with-values (lambda () (visit-top-level expr mod-vars)) 229 (lambda (tail mod-vars) 230 (values 231 (add-binding 'mod 232 mod-var 233 (make-primcall src 'current-module '()) 234 tail) 235 mod-vars))))) 236 (mod-var 237 (let* ((loc 238 (make-primcall src 'module-ensure-local-variable! 239 (list (make-lexical-ref src 'mod mod-var) 240 (make-const src name)))) 241 (exp (visit-expr exp)) 242 (ref (make-lexical-ref src name value)) 243 (init 244 (make-primcall src '%variable-set! 245 (list (make-lexical-ref src name box) 246 ref)))) 247 (values 248 (add-binding 249 name box loc 250 (add-binding 251 name value exp 252 (add-statement src init (make-void src)))) 253 mod-vars))))))) 254 255 (($ <seq> src head tail) 256 (let*-values (((head mod-vars) (visit-top-level head mod-vars)) 257 ((tail mod-vars) (visit-top-level tail mod-vars))) 258 259 (values (match head 260 (($ <letrec> src2 #t names vars vals head) 261 (fold-right add-binding (add-statement src head tail) 262 names vars vals)) 263 (else 264 (add-statement src head tail))) 265 mod-vars))) 266 267 ;; What would the advantages/disadvantages be if we flattened all 268 ;; bindings here, even those from nested let/letrec? 269 (_ (values (visit-expr expr) mod-vars)))) 270 271 (values (visit-top-level expr '()))) 272