From 66be42cb3859d05ab69132e15cc2bd2bbd76d279 Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Sun, 14 Aug 2011 16:54:14 -0400 Subject: [PATCH] improve management of global special variables * module/language/elisp/bindings.scm (bindings): Remove `globals' field. (global?, mark-global!, map-globals): Remove. All callers changed. * module/language/elisp/compile-tree-il.scm (generate-ensure-global, ensuring-globals): Remove. All callers changed. (global?, ensure-globals!): New procedures. (bind-lexically?): Use new `global?'. (compile-lambda, compile-let, compile-let*): Use `ensure-globals!'. --- module/language/elisp/bindings.scm | 34 +--- module/language/elisp/compile-tree-il.scm | 226 ++++++++++------------ 2 files changed, 109 insertions(+), 151 deletions(-) diff --git a/module/language/elisp/bindings.scm b/module/language/elisp/bindings.scm index 03e1c0051..7a437aded 100644 --- a/module/language/elisp/bindings.scm +++ b/module/language/elisp/bindings.scm @@ -24,9 +24,6 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:export (make-bindings - global? - mark-global! - map-globals with-lexical-bindings with-dynamic-bindings get-lexical-binding)) @@ -36,9 +33,6 @@ ;;; symbols, for which globals need to be created, or mark certain ;;; symbols as lexically bound. ;;; -;;; Needed globals are stored in an association-list that stores a list -;;; of symbols for each module they are needed in. -;;; ;;; The lexical bindings of symbols are stored in a hash-table that ;;; associates symbols to fluids; those fluids are used in the ;;; with-lexical-binding and with-dynamic-binding routines to associate @@ -47,39 +41,15 @@ ;;; Record type used to hold the data necessary. (define-record-type bindings - (%make-bindings globals lexical-bindings) + (%make-bindings lexical-bindings) bindings? - (globals globals set-globals!) (lexical-bindings lexical-bindings set-lexical-bindings!)) ;;; Construct an 'empty' instance of the bindings data structure to be ;;; used at the start of a fresh compilation. (define (make-bindings) - (%make-bindings '() (make-hash-table))) - -(define (global? bindings sym module) - (and=> (assoc-ref (globals bindings) module) (cut memq sym <>))) - -;;; Mark that a given symbol is needed as global in the specified -;;; slot-module. - -(define (mark-global! bindings sym module) - (let* ((old-globals (globals bindings)) - (old-in-module (or (assoc-ref old-globals module) '())) - (new-in-module (lset-adjoin eq? old-in-module sym)) - (new-globals (assoc-set! old-globals module new-in-module))) - (set-globals! bindings new-globals))) - -;;; Cycle through all globals needed in order to generate the code for -;;; their creation or some other analysis. - -(define (map-globals bindings proc) - (append-map - (lambda (module+symbols) - (receive (module symbols) (car+cdr module+symbols) - (map (cut proc module <>) symbols))) - (globals bindings))) + (%make-bindings (make-hash-table))) ;;; Get the current lexical binding (gensym it should refer to in the ;;; current scope) for a symbol or #f if it is dynamically bound. diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm index 3b36cc88b..c26c33068 100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@ -108,26 +108,6 @@ (define (report-error loc . args) (apply error args)) -;;; Generate code to ensure a global symbol is there for further use of -;;; a given symbol. In general during the compilation, those needed are -;;; only tracked with the bindings data structure. Afterwards, however, -;;; for all those needed symbols the globals are really generated with -;;; this routine. - -(define (generate-ensure-global loc sym module) - (make-application loc - (make-module-ref loc runtime 'ensure-fluid! #t) - (list (make-const loc module) - (make-const loc sym)))) - -(define (ensuring-globals loc bindings body) - (make-sequence - loc - `(,@(map-globals (fluid-ref bindings) - (lambda (mod sym) - (generate-ensure-global loc sym mod))) - ,body))) - ;;; Handle access to a variable (reference/setting) correctly depending ;;; on whether it is currently lexically or dynamically bound. lexical ;;; access is done only for references to the value-slot module! @@ -156,11 +136,28 @@ (lambda () (make-module-ref loc module sym #t)) (lambda (lexical) (make-lexical-ref loc lexical lexical)) (lambda () - (mark-global! (fluid-ref bindings-data) sym module) (call-primitive loc 'fluid-ref (make-module-ref loc module sym #t))))) +(define (global? module symbol) + (module-variable module symbol)) + +(define (ensure-globals! loc names body) + (if (every (cut global? (resolve-module value-slot) <>) names) + body + (make-sequence + loc + `(,@(map + (lambda (name) + (ensure-fluid! value-slot name) + (make-application loc + (make-module-ref loc runtime 'ensure-fluid! #t) + (list (make-const loc value-slot) + (make-const loc name)))) + names) + ,body)))) + ;;; Generate code to set a variable. Just as with reference-variable, in ;;; case of a reference to value-slot, we want to generate a lexical set ;;; when the variable has a lexical binding. @@ -177,11 +174,12 @@ (list (make-const loc sym) value))) (lambda (lexical) (make-lexical-set loc lexical lexical value)) (lambda () - (mark-global! (fluid-ref bindings-data) sym module) - (call-primitive loc - 'fluid-set! - (make-module-ref loc module sym #t) - value)))) + (ensure-globals! loc + (list sym) + (call-primitive loc + 'fluid-set! + (make-module-ref loc module sym #t) + value))))) (define (bind-lexically? sym module decls) (or (eq? module function-slot) @@ -191,7 +189,7 @@ (eq? decl 'lexical) (and (fluid-ref lexical-binding) - (not (global? (fluid-ref bindings-data) sym module)))))))) + (not (global? (resolve-module module) sym)))))))) (define (parse-let-binding loc binding) (pmatch binding @@ -321,27 +319,30 @@ lexical-ids lexical-vars (lambda () - (let* ((tree-il (compile-expr `(progn ,@forms))) - (full-body - (if (null? dynamic) - tree-il - (make-dynlet - loc - (map (cut make-module-ref loc value-slot <> #t) - dynamic-ids) - (map (cut make-lexical-ref loc <> <>) - dynamic-ids - dynamic-vars) - tree-il)))) - (make-simple-lambda loc - meta - req-ids - opt-ids - (map (const (nil-value loc)) - opt-ids) - rest-id - all-vars - full-body)))))))) + (ensure-globals! + loc + dynamic-ids + (let* ((tree-il (compile-expr `(progn ,@forms))) + (full-body + (if (null? dynamic) + tree-il + (make-dynlet + loc + (map (cut make-module-ref loc value-slot <> #t) + dynamic-ids) + (map (cut make-lexical-ref loc <> <>) + dynamic-ids + dynamic-vars) + tree-il)))) + (make-simple-lambda loc + meta + req-ids + opt-ids + (map (const (nil-value loc)) + opt-ids) + rest-id + all-vars + full-body))))))))) (report-error "invalid function" `(lambda ,args ,@body))))) ;;; Handle the common part of defconst and defvar, that is, checking for @@ -508,73 +509,65 @@ (compose (cut bind-lexically? <> value-slot decls) car) bindings) - (for-each (lambda (sym) - (mark-global! (fluid-ref bindings-data) - sym - value-slot)) - (map car dynamic)) (let ((make-values (lambda (for) (map (lambda (el) (compile-expr (cdr el))) for))) (make-body (lambda () (compile-expr `(progn ,@forms))))) - (if (null? lexical) - (make-dynlet loc - (map (compose (cut make-module-ref - loc - value-slot - <> - #t) - car) - dynamic) - (map (compose compile-expr cdr) - dynamic) - (make-body)) - (let* ((lexical-syms (map (lambda (el) (gensym)) lexical)) - (dynamic-syms (map (lambda (el) (gensym)) dynamic)) - (all-syms (append lexical-syms dynamic-syms)) - (vals (append (make-values lexical) - (make-values dynamic)))) - (make-let loc - all-syms - all-syms - vals - (with-lexical-bindings - (fluid-ref bindings-data) - (map car lexical) - lexical-syms - (lambda () - (if (null? dynamic) - (make-body) - (make-dynlet loc - (map - (compose - (cut make-module-ref - loc - value-slot - <> - #t) - car) - dynamic) - (map - (lambda (sym) - (make-lexical-ref - loc - sym - sym)) - dynamic-syms) - (make-body))))))))))))))) + (ensure-globals! + loc + (map car dynamic) + (if (null? lexical) + (make-dynlet loc + (map (compose (cut make-module-ref + loc + value-slot + <> + #t) + car) + dynamic) + (map (compose compile-expr cdr) + dynamic) + (make-body)) + (let* ((lexical-syms (map (lambda (el) (gensym)) lexical)) + (dynamic-syms (map (lambda (el) (gensym)) dynamic)) + (all-syms (append lexical-syms dynamic-syms)) + (vals (append (make-values lexical) + (make-values dynamic)))) + (make-let loc + all-syms + all-syms + vals + (with-lexical-bindings + (fluid-ref bindings-data) + (map car lexical) + lexical-syms + (lambda () + (if (null? dynamic) + (make-body) + (make-dynlet loc + (map + (compose + (cut make-module-ref + loc + value-slot + <> + #t) + car) + dynamic) + (map + (lambda (sym) + (make-lexical-ref + loc + sym + sym)) + dynamic-syms) + (make-body)))))))))))))))) (defspecial let* (loc args) (pmatch args ((,varlist . ,body) (let ((bindings (map (cut parse-let-binding loc <>) varlist))) (receive (decls forms) (parse-body body) - (for-each (lambda (sym) - (if (not (bind-lexically? sym value-slot decls)) - (mark-global! (fluid-ref bindings-data) - sym - value-slot))) - (map car bindings)) (let iterate ((tail bindings)) (if (null? tail) (compile-expr `(progn ,@forms)) @@ -591,10 +584,13 @@ `(,sym) `(,target) (lambda () (iterate (cdr tail)))))) - (make-dynlet loc - (list (make-module-ref loc value-slot sym #t)) - (list value) - (iterate (cdr tail)))))))))))) + (ensure-globals! + loc + (list sym) + (make-dynlet loc + (list (make-module-ref loc value-slot sym #t)) + (list value) + (iterate (cdr tail))))))))))))) (defspecial flet (loc args) (pmatch args @@ -682,9 +678,7 @@ args body)))) (make-const loc name))))) - (compile (ensuring-globals loc bindings-data tree-il) - #:from 'tree-il - #:to 'value) + (compile tree-il #:from 'tree-il #:to 'value) tree-il))))) (defspecial defun (loc args) @@ -781,16 +775,10 @@ "Invalid compiler option" key))))))) -;;; Entry point for compilation to TreeIL. This creates the bindings -;;; data structure, and after compiling the main expression we need to -;;; make sure all globals for symbols used during the compilation are -;;; created using the generate-ensure-global function. - (define (compile-tree-il expr env opts) (values (with-fluids ((bindings-data (make-bindings))) (process-options! opts) - (let ((compiled (compile-expr expr))) - (ensuring-globals (location expr) bindings-data compiled))) + (compile-expr expr)) env env))