mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-31 17:30:24 +02:00
Code Activity

improve management of global special variables

Browse source 
* 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!'.
This commit is contained in:
BT Templeton 2011-08-14 16:54:14 -04:00
parent b07a74497a
commit 66be42cb38
2 changed files with 109 additions and 151 deletions
Download patch file Download diff file Expand all files Collapse all files

34
module/language/elisp/bindings.scm
View file

@ -24,9 +24,6 @@
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:export (make-bindings #:export (make-bindings
global?
mark-global!
map-globals
with-lexical-bindings with-lexical-bindings
with-dynamic-bindings with-dynamic-bindings
get-lexical-binding)) get-lexical-binding))
@ -36,9 +33,6 @@
;;; symbols, for which globals need to be created, or mark certain ;;; symbols, for which globals need to be created, or mark certain
;;; symbols as lexically bound. ;;; 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 ;;; The lexical bindings of symbols are stored in a hash-table that
;;; associates symbols to fluids; those fluids are used in the ;;; associates symbols to fluids; those fluids are used in the
;;; with-lexical-binding and with-dynamic-binding routines to associate ;;; with-lexical-binding and with-dynamic-binding routines to associate
@ -47,39 +41,15 @@
;;; Record type used to hold the data necessary. ;;; Record type used to hold the data necessary.
(define-record-type bindings (define-record-type bindings
(%make-bindings globals lexical-bindings) (%make-bindings lexical-bindings)
bindings? bindings?
(globals globals set-globals!)
(lexical-bindings lexical-bindings set-lexical-bindings!)) (lexical-bindings lexical-bindings set-lexical-bindings!))
;;; Construct an 'empty' instance of the bindings data structure to be ;;; Construct an 'empty' instance of the bindings data structure to be
;;; used at the start of a fresh compilation. ;;; used at the start of a fresh compilation.
(define (make-bindings) (define (make-bindings)
(%make-bindings '() (make-hash-table))) (%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)))
;;; Get the current lexical binding (gensym it should refer to in the ;;; Get the current lexical binding (gensym it should refer to in the
;;; current scope) for a symbol or #f if it is dynamically bound. ;;; current scope) for a symbol or #f if it is dynamically bound.

226
module/language/elisp/compile-tree-il.scm
View file

@ -108,26 +108,6 @@
(define (report-error loc . args) (define (report-error loc . args)
(apply error 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 ;;; Handle access to a variable (reference/setting) correctly depending
;;; on whether it is currently lexically or dynamically bound. lexical ;;; on whether it is currently lexically or dynamically bound. lexical
;;; access is done only for references to the value-slot module! ;;; access is done only for references to the value-slot module!
@ -156,11 +136,28 @@
(lambda () (make-module-ref loc module sym #t)) (lambda () (make-module-ref loc module sym #t))
(lambda (lexical) (make-lexical-ref loc lexical lexical)) (lambda (lexical) (make-lexical-ref loc lexical lexical))
(lambda () (lambda ()
(mark-global! (fluid-ref bindings-data) sym module)
(call-primitive loc (call-primitive loc
'fluid-ref 'fluid-ref
(make-module-ref loc module sym #t))))) (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 ;;; 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 ;;; case of a reference to value-slot, we want to generate a lexical set
;;; when the variable has a lexical binding. ;;; when the variable has a lexical binding.
@ -177,11 +174,12 @@
(list (make-const loc sym) value))) (list (make-const loc sym) value)))
(lambda (lexical) (make-lexical-set loc lexical lexical value)) (lambda (lexical) (make-lexical-set loc lexical lexical value))
(lambda () (lambda ()
(mark-global! (fluid-ref bindings-data) sym module) (ensure-globals! loc
(call-primitive loc (list sym)
'fluid-set! (call-primitive loc
(make-module-ref loc module sym #t) 'fluid-set!
value)))) (make-module-ref loc module sym #t)
value)))))
(define (bind-lexically? sym module decls) (define (bind-lexically? sym module decls)
(or (eq? module function-slot) (or (eq? module function-slot)
@ -191,7 +189,7 @@
(eq? decl 'lexical) (eq? decl 'lexical)
(and (and
(fluid-ref lexical-binding) (fluid-ref lexical-binding)
(not (global? (fluid-ref bindings-data) sym module)))))))) (not (global? (resolve-module module) sym))))))))
(define (parse-let-binding loc binding) (define (parse-let-binding loc binding)
(pmatch binding (pmatch binding
@ -321,27 +319,30 @@
lexical-ids lexical-ids
lexical-vars lexical-vars
(lambda () (lambda ()
(let* ((tree-il (compile-expr `(progn ,@forms))) (ensure-globals!
(full-body loc
(if (null? dynamic) dynamic-ids
tree-il (let* ((tree-il (compile-expr `(progn ,@forms)))
(make-dynlet (full-body
loc (if (null? dynamic)
(map (cut make-module-ref loc value-slot <> #t) tree-il
dynamic-ids) (make-dynlet
(map (cut make-lexical-ref loc <> <>) loc
dynamic-ids (map (cut make-module-ref loc value-slot <> #t)
dynamic-vars) dynamic-ids)
tree-il)))) (map (cut make-lexical-ref loc <> <>)
(make-simple-lambda loc dynamic-ids
meta dynamic-vars)
req-ids tree-il))))
opt-ids (make-simple-lambda loc
(map (const (nil-value loc)) meta
opt-ids) req-ids
rest-id opt-ids
all-vars (map (const (nil-value loc))
full-body)))))))) opt-ids)
rest-id
all-vars
full-body)))))))))
(report-error "invalid function" `(lambda ,args ,@body))))) (report-error "invalid function" `(lambda ,args ,@body)))))
;;; Handle the common part of defconst and defvar, that is, checking for ;;; Handle the common part of defconst and defvar, that is, checking for
@ -508,73 +509,65 @@
(compose (cut bind-lexically? <> value-slot decls) (compose (cut bind-lexically? <> value-slot decls)
car) car)
bindings) bindings)
(for-each (lambda (sym)
(mark-global! (fluid-ref bindings-data)
sym
value-slot))
(map car dynamic))
(let ((make-values (lambda (for) (let ((make-values (lambda (for)
(map (lambda (el) (compile-expr (cdr el))) (map (lambda (el) (compile-expr (cdr el)))
for))) for)))
(make-body (lambda () (compile-expr `(progn ,@forms))))) (make-body (lambda () (compile-expr `(progn ,@forms)))))
(if (null? lexical) (ensure-globals!
(make-dynlet loc loc
(map (compose (cut make-module-ref (map car dynamic)
loc (if (null? lexical)
value-slot (make-dynlet loc
<> (map (compose (cut make-module-ref
#t) loc
car) value-slot
dynamic) <>
(map (compose compile-expr cdr) #t)
dynamic) car)
(make-body)) dynamic)
(let* ((lexical-syms (map (lambda (el) (gensym)) lexical)) (map (compose compile-expr cdr)
(dynamic-syms (map (lambda (el) (gensym)) dynamic)) dynamic)
(all-syms (append lexical-syms dynamic-syms)) (make-body))
(vals (append (make-values lexical) (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
(make-values dynamic)))) (dynamic-syms (map (lambda (el) (gensym)) dynamic))
(make-let loc (all-syms (append lexical-syms dynamic-syms))
all-syms (vals (append (make-values lexical)
all-syms (make-values dynamic))))
vals (make-let loc
(with-lexical-bindings all-syms
(fluid-ref bindings-data) all-syms
(map car lexical) vals
lexical-syms (with-lexical-bindings
(lambda () (fluid-ref bindings-data)
(if (null? dynamic) (map car lexical)
(make-body) lexical-syms
(make-dynlet loc (lambda ()
(map (if (null? dynamic)
(compose (make-body)
(cut make-module-ref (make-dynlet loc
loc (map
value-slot (compose
<> (cut make-module-ref
#t) loc
car) value-slot
dynamic) <>
(map #t)
(lambda (sym) car)
(make-lexical-ref dynamic)
loc (map
sym (lambda (sym)
sym)) (make-lexical-ref
dynamic-syms) loc
(make-body))))))))))))))) sym
sym))
dynamic-syms)
(make-body))))))))))))))))
(defspecial let* (loc args) (defspecial let* (loc args)
(pmatch args (pmatch args
((,varlist . ,body) ((,varlist . ,body)
(let ((bindings (map (cut parse-let-binding loc <>) varlist))) (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
(receive (decls forms) (parse-body body) (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)) (let iterate ((tail bindings))
(if (null? tail) (if (null? tail)
(compile-expr `(progn ,@forms)) (compile-expr `(progn ,@forms))
@ -591,10 +584,13 @@
`(,sym) `(,sym)
`(,target) `(,target)
(lambda () (iterate (cdr tail)))))) (lambda () (iterate (cdr tail))))))
(make-dynlet loc (ensure-globals!
(list (make-module-ref loc value-slot sym #t)) loc
(list value) (list sym)
(iterate (cdr tail)))))))))))) (make-dynlet loc
(list (make-module-ref loc value-slot sym #t))
(list value)
(iterate (cdr tail)))))))))))))
(defspecial flet (loc args) (defspecial flet (loc args)
(pmatch args (pmatch args
@ -682,9 +678,7 @@
args args
body)))) body))))
(make-const loc name))))) (make-const loc name)))))
(compile (ensuring-globals loc bindings-data tree-il) (compile tree-il #:from 'tree-il #:to 'value)
#:from 'tree-il
#:to 'value)
tree-il))))) tree-il)))))
(defspecial defun (loc args) (defspecial defun (loc args)
@ -781,16 +775,10 @@
"Invalid compiler option" "Invalid compiler option"
key))))))) 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) (define (compile-tree-il expr env opts)
(values (values
(with-fluids ((bindings-data (make-bindings))) (with-fluids ((bindings-data (make-bindings)))
(process-options! opts) (process-options! opts)
(let ((compiled (compile-expr expr))) (compile-expr expr))
(ensuring-globals (location expr) bindings-data compiled)))
env env
env)) env))