Don't ensure fluids all over the place but scan for variables needed and ensure just before the compiled code all those.

* module/language/elisp/README: Document this.
* module/language/elisp/compile-tree-il.scm: Implement it here, pass bindings all around the compilation.
* module/language/elisp/bindings.scm: New module with symbol-tracking abilities needed for this.

module/language/elisp/README

@@ -31,8 +31,5 @@ Especially still missing:
   * anonymous macros
 
 Other ideas and things to think about:
-  * %nil vs. #f/'() handling in Guile, possibly get rid of setting empty rest
+  * %nil vs. #f/'() handling in Guile
-    arguments to %nil
   * don't ensure-fluids for variables known to be let- or argument-bound
-  * or, perhaps, get rid of ensure-fluids over all but rather scan all code for
-    variables and create all needed fluids beforehand

module/language/elisp/bindings.scm

@@ -0,0 +1,74 @@
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language elisp bindings)
+  #:export (make-bindings mark-fluid-needed! map-fluids-needed))
+
+; This module defines routines to handle analysis of symbol bindings used
+; during elisp compilation.  This data allows to collect the symbols, for
+; which fluids need to be created, or mark certain symbols as lexically bound.
+
+
+; Record type used to hold the data necessary.
+
+(define bindings-type (make-record-type 'bindings '(needed-fluids)))
+
+
+; Construct an 'empty' instance of the bindings data structure to be used
+; at the start of a fresh compilation.
+
+(define (make-bindings)
+  ((record-constructor bindings-type) '()))
+
+
+; Mark that a given symbol is needed as fluid in the specified slot-module.
+
+(define (mark-fluid-needed! bindings sym module)
+  (let* ((old-needed ((record-accessor bindings-type 'needed-fluids) bindings))
+         (old-in-module (or (assoc-ref old-needed module) '()))
+         (new-in-module (if (memq sym old-in-module)
+                          old-in-module
+                          (cons sym old-in-module)))
+         (new-needed (assoc-set! old-needed module new-in-module)))
+    ((record-modifier bindings-type 'needed-fluids) bindings new-needed)))
+
+
+; Cycle through all fluids needed in order to generate the code for their
+; creation or some other analysis.
+
+(define (map-fluids-needed bindings proc)
+  (let* ((needed ((record-accessor bindings-type 'needed-fluids) bindings)))
+    (let iterate-modules ((mod-tail needed)
+                          (mod-result '()))
+      (if (null? mod-tail)
+        mod-result
+        (iterate-modules
+          (cdr mod-tail)
+          (let* ((aentry (car mod-tail))
+                 (module (car aentry))
+                 (symbols (cdr aentry)))
+            (let iterate-symbols ((sym-tail symbols)
+                                  (sym-result mod-result))
+              (if (null? sym-tail)
+                sym-result
+                (iterate-symbols (cdr sym-tail)
+                                 (cons (proc module (car sym-tail))
+                                       sym-result))))))))))

module/language/elisp/compile-tree-il.scm

@@ -20,6 +20,7 @@
 ;;; Code:
 
 (define-module (language elisp compile-tree-il)
+  #:use-module (language elisp bindings)
   #:use-module (language tree-il)
   #:use-module (system base pmatch)
   #:use-module (system base compile)
@@ -88,11 +89,11 @@
 
 
 ; Generate code to ensure a fluid is there for further use of a given symbol.
-; ensure-fluids-for does the same for a list of symbols and builds a sequence
+; In general during the compilation, fluids needed are only tracked with the
-; that executes the fluid-insurances first, followed by all body commands; this
+; bindings data structure.  Afterwards, however, for all those needed symbols
-; is a routine for convenience (needed with let, let*, lambda).
+; the fluids are really generated with this routine.
 
-(define (ensure-fluid! loc sym module)
+(define (generate-ensure-fluid loc sym module)
   (let ((resolved-module (call-primitive loc 'resolve-module
                                          (make-const loc module)))
         (resolved-intf (call-primitive loc 'resolve-interface
@@ -112,26 +113,19 @@
                 (make-module-ref loc runtime 'void #t)))))))
 
 
-(define (ensure-fluids-for loc syms module . body)
-  (make-sequence loc
-    `(,@(map (lambda (sym) (ensure-fluid! loc sym module)) syms)
-      ,@body)))
-
-
 ; Generate code to reference a fluid saved variable.
 
-(define (reference-variable loc sym module)
+(define (reference-variable loc bind sym module)
-  (make-sequence loc
+  (mark-fluid-needed! bind sym module)
-    (list (ensure-fluid! loc sym module)
+  (call-primitive loc 'fluid-ref
-          (call-primitive loc 'fluid-ref
+                  (make-module-ref loc module sym #t)))
-                          (make-module-ref loc module sym #t)))))
 
 
 ; Reference a variable and error if the value is void.
 
-(define (reference-with-check loc sym module)
+(define (reference-with-check loc bind sym module)
   (let ((var (gensym)))
-    (make-let loc '(value) `(,var) `(,(reference-variable loc sym module))
+    (make-let loc '(value) `(,var) `(,(reference-variable loc bind sym module))
       (make-conditional loc
         (call-primitive loc 'eq?
                         (make-module-ref loc runtime 'void #t)
@@ -142,12 +136,10 @@
 
 ; Generate code to set a fluid saved variable.
 
-(define (set-variable! loc sym module value)
+(define (set-variable! loc bind sym module value)
-  (make-sequence loc
+  (mark-fluid-needed! bind sym module)
-    (list (ensure-fluid! loc sym module)
+  (call-primitive loc 'fluid-set!
-          (call-primitive loc 'fluid-set!
+                  (make-module-ref loc module sym #t) value))
-                          (make-module-ref loc module sym #t)
-                          value))))
 
 
 ; Process the bindings part of a let or let* expression; that is, check for
@@ -221,7 +213,7 @@
 ; This is formulated quite imperatively, but I think in this case that is quite
 ; clear and better than creating a lot of nested let's.
 
-(define (compile-lambda loc args body)
+(define (compile-lambda loc bind args body)
   (if (not (list? args))
     (error "expected list for argument-list" args))
   (if (null? body)
@@ -236,7 +228,10 @@
               (locals `(,@required ,@optional ,@(if rest (list rest) '()))))
           (make-lambda loc
             real-args real-args '()
-            (ensure-fluids-for loc locals value-slot
+            (begin
+              (for-each (lambda (sym)
+                          (mark-fluid-needed! bind sym value-slot))
+                        locals)
               (call-primitive loc 'with-fluids*
                 (make-application loc (make-primitive-ref loc 'list)
                   (map (lambda (sym) (make-module-ref loc value-slot sym #t))
@@ -250,13 +245,13 @@
                                  optional))))
                 (make-lambda loc '() '() '()
                   (make-sequence loc
-                    `(,(process-optionals loc optional rest-sym)
+                    `(,(process-optionals loc bind optional rest-sym)
-                      ,(process-rest loc rest rest-sym)
+                      ,(process-rest loc bind rest rest-sym)
-                      ,@(map compile-expr body))))))))))))
+                      ,@(map (compiler bind) body))))))))))))
 
 ; Build the code to handle setting of optional arguments that are present
 ; and updating the rest list.
-(define (process-optionals loc optional rest-sym)
+(define (process-optionals loc bind optional rest-sym)
   (let iterate ((tail optional))
     (if (null? tail)
       (make-void loc)
@@ -264,7 +259,7 @@
         (call-primitive loc 'null? (make-lexical-ref loc rest-sym rest-sym))
         (make-void loc)
         (make-sequence loc
-          (list (set-variable! loc (car tail) value-slot
+          (list (set-variable! loc bind (car tail) value-slot
                   (call-primitive loc 'car
                                   (make-lexical-ref loc rest-sym rest-sym)))
                 (make-lexical-set loc rest-sym rest-sym
@@ -273,14 +268,14 @@
                 (iterate (cdr tail))))))))
 
 ; This builds the code to set the rest variable to nil if it is empty.
-(define (process-rest loc rest rest-sym)
+(define (process-rest loc bind rest rest-sym)
   (let ((rest-empty (call-primitive loc 'null?
                                     (make-lexical-ref loc rest-sym rest-sym))))
     (cond
       (rest
        (make-conditional loc rest-empty
          (make-void loc)
-         (set-variable! loc rest value-slot
+         (set-variable! loc bind rest value-slot
                         (make-lexical-ref loc rest-sym rest-sym))))
       ((not (null? rest-sym))
        (make-conditional loc rest-empty
@@ -343,24 +338,24 @@
 (define (unquote-splicing-cell? expr)
   (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
 
-(define (process-backquote loc expr)
+(define (process-backquote loc bind expr)
   (if (contains-unquotes? expr)
     (if (pair? expr)
       (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
-        (compile-expr (cadr expr))
+        (compile-expr bind (cadr expr))
         (let* ((head (car expr))
-               (processed-tail (process-backquote loc (cdr expr)))
+               (processed-tail (process-backquote loc bind (cdr expr)))
                (head-is-list-2 (and (list? head) (= (length head) 2)))
                (head-unquote (and head-is-list-2 (unquote? (car head))))
                (head-unquote-splicing (and head-is-list-2
                                            (unquote-splicing? (car head)))))
           (if head-unquote-splicing
             (call-primitive loc 'append
-              (compile-expr (cadr head)) processed-tail)
+              (compile-expr bind (cadr head)) processed-tail)
             (call-primitive loc 'cons
               (if head-unquote
-                (compile-expr (cadr head))
+                (compile-expr bind (cadr head))
-                (process-backquote loc head))
+                (process-backquote loc bind head))
               processed-tail))))
       (error "non-pair expression contains unquotes" expr))
     (make-const loc expr)))
@@ -377,76 +372,74 @@
 ;           body
 ;           (iterate (cdr tail)))))))
 
-(define (compile-dolist loc var iter-list result body)
+(define (compile-dolist loc bind var iter-list result body)
   (let* ((tailvar (gensym))
          (iterate (gensym))
          (tailref (make-lexical-ref loc tailvar tailvar))
          (iterate-func (make-lambda loc `(,tailvar) `(,tailvar) '()
                          (make-conditional loc
                            (call-primitive loc 'null? tailref)
-                           (compile-expr result)
+                           (compile-expr bind result)
                            (make-sequence loc
-                             `(,(set-variable! loc var value-slot
+                             `(,(set-variable! loc bind var value-slot
                                   (call-primitive loc 'car tailref))
-                               ,@(map compile-expr body)
+                               ,@(map (compiler bind) body)
                                ,(make-application loc
                                   (make-lexical-ref loc iterate iterate)
                                   (list (call-primitive loc 'cdr
                                           tailref)))))))))
-
+    (mark-fluid-needed! bind var value-slot)
-    (make-sequence loc
+    (call-primitive loc 'with-fluid*
-      (list (ensure-fluid! loc var value-slot)
+      (make-module-ref loc value-slot var #t)
-            (call-primitive loc 'with-fluid*
+      (nil-value loc)
-              (make-module-ref loc value-slot var #t)
+      (make-lambda loc '() '() '()
-              (nil-value loc)
+        (make-letrec loc `(,iterate) `(,iterate) `(,iterate-func)
-              (make-lambda loc '() '() '()
+          (make-application loc
-                (make-letrec loc `(,iterate) `(,iterate) `(,iterate-func)
+            (make-lexical-ref loc iterate iterate)
-                  (make-application loc
+            (list (compile-expr bind iter-list))))))))
-                    (make-lexical-ref loc iterate iterate)
-                    (list (compile-expr iter-list))))))))))
 
 
 
 ; Compile a symbol expression.  This is a variable reference or maybe some
 ; special value like nil.
 
-(define (compile-symbol loc sym)
+(define (compile-symbol loc bind sym)
   (case sym
     ((nil) (nil-value loc))
     ((t) (t-value loc))
-    (else (reference-with-check loc sym value-slot))))
+    (else (reference-with-check loc bind sym value-slot))))
 
 
 ; Compile a pair-expression (that is, any structure-like construct).
 
-(define (compile-pair loc expr)
+(define (compile-pair loc bind expr)
   (pmatch expr
 
     ((progn . ,forms)
-     (make-sequence loc (map compile-expr forms)))
+     (make-sequence loc (map (compiler bind) forms)))
 
     ; I chose to implement prog1 directly (not with macros) so that the
     ; temporary variable used can be a lexical one that is not backed by a fluid
     ; for better performance.
     ((prog1 ,form1 . ,forms)
      (let ((temp (gensym)))
-       (make-let loc `(,temp) `(,temp) `(,(compile-expr form1))
+       (make-let loc `(,temp) `(,temp) `(,(compile-expr bind form1))
          (make-sequence loc
-           (append (map compile-expr forms)
+           (append (map (compiler bind) forms)
                    (list (make-lexical-ref loc temp temp)))))))
 
     ((if ,condition ,ifclause)
-     (make-conditional loc (compile-expr condition)
+     (make-conditional loc (compile-expr bind condition)
-                           (compile-expr ifclause)
+                           (compile-expr bind ifclause)
                            (nil-value loc)))
     ((if ,condition ,ifclause ,elseclause)
-     (make-conditional loc (compile-expr condition)
+     (make-conditional loc (compile-expr bind condition)
-                           (compile-expr ifclause)
+                           (compile-expr bind ifclause)
-                           (compile-expr elseclause)))
+                           (compile-expr bind elseclause)))
     ((if ,condition ,ifclause . ,elses)
-     (make-conditional loc (compile-expr condition)
+     (make-conditional loc (compile-expr bind condition)
-                           (compile-expr ifclause)
+                           (compile-expr bind ifclause)
-                           (make-sequence loc (map compile-expr elses))))
+                           (make-sequence loc (map (compiler bind) elses))))
 
     ; For (cond ...) forms, a special case is a (condition) clause without
     ; body.  In this case, the value of condition itself should be returned,
@@ -462,23 +455,23 @@
            (if (null? (cdr cur))
              (let ((var (gensym)))
                (make-let loc
-                 '(condition) `(,var) `(,(compile-expr (car cur)))
+                 '(condition) `(,var) `(,(compile-expr bind (car cur)))
                  (make-conditional loc
                    (make-lexical-ref loc 'condition var)
                    (make-lexical-ref loc 'condition var)
                    (iterate (cdr tail)))))
              (make-conditional loc
-               (compile-expr (car cur))
+               (compile-expr bind (car cur))
-               (make-sequence loc (map compile-expr (cdr cur)))
+               (make-sequence loc (map (compiler bind) (cdr cur)))
                (iterate (cdr tail))))))))
 
     ((and) (t-value loc))
     ((and . ,expressions)
      (let iterate ((tail expressions))
        (if (null? (cdr tail))
-         (compile-expr (car tail))
+         (compile-expr bind (car tail))
          (make-conditional loc
-           (compile-expr (car tail))
+           (compile-expr bind (car tail))
            (iterate (cdr tail))
            (nil-value loc)))))
 
@@ -488,7 +481,7 @@
          (nil-value loc)
          (let ((var (gensym)))
            (make-let loc
-             '(condition) `(,var) `(,(compile-expr (car tail)))
+             '(condition) `(,var) `(,(compile-expr bind (car tail)))
              (make-conditional loc
                (make-lexical-ref loc 'condition var)
                (make-lexical-ref loc 'condition var)
@@ -497,7 +490,7 @@
     ((defconst ,sym ,value . ,doc)
      (if (handle-var-def loc sym doc)
        (make-sequence loc
-         (list (set-variable! loc sym value-slot (compile-expr value))
+         (list (set-variable! loc bind sym value-slot (compile-expr bind value))
                (make-const loc sym)))))
 
     ((defvar ,sym) (make-const loc sym))
@@ -507,8 +500,9 @@
          (list (make-conditional loc
                  (call-primitive loc 'eq?
                                  (make-module-ref loc runtime 'void #t)
-                                 (reference-variable loc sym value-slot))
+                                 (reference-variable loc bind sym value-slot))
-                 (set-variable! loc sym value-slot (compile-expr value))
+                 (set-variable! loc bind sym value-slot
+                                (compile-expr bind value))
                  (make-void loc))
                (make-const loc sym)))))
 
@@ -524,37 +518,40 @@
              (report-error loc "expected symbol in setq")
              (if (null? tailtail)
                (report-error loc "missing value for symbol in setq" sym)
-               (let* ((val (compile-expr (car tailtail)))
+               (let* ((val (compile-expr bind (car tailtail)))
-                      (op (set-variable! loc sym value-slot val)))
+                      (op (set-variable! loc bind sym value-slot val)))
                  (if (null? (cdr tailtail))
                    (let* ((temp (gensym))
                           (ref (make-lexical-ref loc temp temp)))
                      (list (make-let loc `(,temp) `(,temp) `(,val)
                              (make-sequence loc
-                               (list (set-variable! loc sym value-slot ref)
+                               (list (set-variable! loc bind sym value-slot ref)
                                      ref)))))
-                   (cons (set-variable! loc sym value-slot val)
+                   (cons (set-variable! loc bind sym value-slot val)
                          (iterate (cdr tailtail)))))))))))
 
     ; Let is done with a single call to with-fluids* binding them locally to new
-    ; values.
+    ; values all "at once".
     ((let ,bindings . ,body) (guard (and (list? bindings)
                                          (list? body)
                                          (not (null? bindings))
                                          (not (null? body))))
-     (let ((bind (process-let-bindings loc bindings)))
+     (let ((let-bind (process-let-bindings loc bindings)))
-       (ensure-fluids-for loc (map car bind) value-slot
+       (begin
+         (for-each (lambda (sym)
+                     (mark-fluid-needed! bind sym value-slot))
+                   (map car let-bind))
          (call-primitive loc 'with-fluids*
            (make-application loc (make-primitive-ref loc 'list)
              (map (lambda (el)
-                 (make-module-ref loc value-slot (car el) #t))
+                    (make-module-ref loc value-slot (car el) #t))
-               bind))
+                  let-bind))
            (make-application loc (make-primitive-ref loc 'list)
              (map (lambda (el)
-                    (compile-expr (cdr el)))
+                    (compile-expr bind (cdr el)))
-                  bind))
+                  let-bind))
            (make-lambda loc '() '() '() 
-             (make-sequence loc (map compile-expr body)))))))
+             (make-sequence loc (map (compiler bind) body)))))))
 
     ; Let* is compiled to a cascaded set of with-fluid* for each binding in turn
     ; so that each one already sees the preceding bindings.
@@ -562,14 +559,17 @@
                                           (list? body)
                                           (not (null? bindings))
                                           (not (null? body))))
-     (let ((bind (process-let-bindings loc bindings)))
+     (let ((let-bind (process-let-bindings loc bindings)))
-       (ensure-fluids-for loc (map car bind) value-slot
+       (begin
-         (let iterate ((tail bind))
+         (for-each (lambda (sym)
+                     (mark-fluid-needed! bind sym value-slot))
+                   (map car let-bind))
+         (let iterate ((tail let-bind))
            (if (null? tail)
-             (make-sequence loc (map compile-expr body))
+             (make-sequence loc (map (compiler bind) body))
              (call-primitive loc 'with-fluid*
                (make-module-ref loc value-slot (caar tail) #t)
-               (compile-expr (cdar tail))
+               (compile-expr bind (cdar tail))
                (make-lambda loc '() '() '() (iterate (cdr tail)))))))))
 
     ; A while construct is transformed into a tail-recursive loop like this:
@@ -581,14 +581,14 @@
     ;   (iterate))
     ((while ,condition . ,body)
      (let* ((itersym (gensym))
-            (compiled-body (map compile-expr body))
+            (compiled-body (map (compiler bind) body))
             (iter-call (make-application loc
                          (make-lexical-ref loc 'iterate itersym)
                          (list)))
             (full-body (make-sequence loc
                          `(,@compiled-body ,iter-call)))
             (lambda-body (make-conditional loc
-                           (compile-expr condition)
+                           (compile-expr bind condition)
                            full-body
                            (nil-value loc)))
             (iter-thunk (make-lambda loc '() '() '() lambda-body)))
@@ -598,24 +598,24 @@
     ; dolist is treated here rather than as macro because it can take advantage
     ; of a non-fluid-based variable.
     ((dolist (,var ,iter-list) . ,body) (guard (symbol? var))
-     (compile-dolist loc var iter-list 'nil body))
+     (compile-dolist loc bind var iter-list 'nil body))
     ((dolist (,var ,iter-list ,result) . ,body) (guard (symbol? var))
-     (compile-dolist loc var iter-list result body))
+     (compile-dolist loc bind var iter-list result body))
 
     ; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression
     ; that should be compiled.
     ((lambda ,args . ,body)
-     (compile-lambda loc args body))
+     (compile-lambda loc bind args body))
     ((function (lambda ,args . ,body))
-     (compile-lambda loc args body))
+     (compile-lambda loc bind args body))
 
     ; Build a lambda and also assign it to the function cell of some symbol.
     ((defun ,name ,args . ,body)
      (if (not (symbol? name))
        (error "expected symbol as function name" name)
        (make-sequence loc
-         (list (set-variable! loc name function-slot
+         (list (set-variable! loc bind name function-slot
-                              (compile-lambda loc args body))
+                              (compile-lambda loc bind args body))
                (make-const loc name)))))
 
     ; Define a macro (this is done directly at compile-time!).
@@ -623,13 +623,13 @@
     ((defmacro ,name ,args . ,body)
      (if (not (symbol? name))
        (error "expected symbol as macro name" name)
-       (let* ((tree-il (compile-lambda loc args body))
+       (let* ((tree-il (compile-lambda loc (make-bindings) args body))
               (object (compile tree-il #:from 'tree-il #:to 'value)))
          (define-macro! loc name object)
          (make-const loc name))))
 
     ((,backq ,val) (guard (backquote? backq))
-     (process-backquote loc val))
+     (process-backquote loc bind val))
 
     ; XXX: Why do we need 'quote here instead of quote?
     (('quote ,val)
@@ -638,7 +638,7 @@
     ; Macro calls are simply expanded and recursively compiled.
     ((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro)))
      (let ((expander (get-macro macro)))
-       (compile-expr (apply expander args))))
+       (compile-expr bind (apply expander args))))
 
     ; Function calls using (function args) standard notation; here, we have to
     ; take the function value of a symbol if it is one.  It seems that functions
@@ -647,9 +647,9 @@
     ((,func . ,args)
      (make-application loc
        (if (symbol? func)
-         (reference-with-check loc func function-slot)
+         (reference-with-check loc bind func function-slot)
-         (compile-expr func))
+         (compile-expr bind func))
-       (map compile-expr args)))
+       (map (compiler bind) args)))
 
     (else
       (report-error loc "unrecognized elisp" expr))))
@@ -657,20 +657,30 @@
 
 ; Compile a single expression to TreeIL.
 
-(define (compile-expr expr)
+(define (compile-expr bind expr)
   (let ((loc (location expr)))
     (cond
       ((symbol? expr)
-       (compile-symbol loc expr))
+       (compile-symbol loc bind expr))
       ((pair? expr)
-       (compile-pair loc expr))
+       (compile-pair loc bind expr))
       (else (make-const loc expr)))))
 
+(define (compiler bind)
+  (lambda (expr)
+    (compile-expr bind expr)))
+
 
 ; Entry point for compilation to TreeIL.
 
 (define (compile-tree-il expr env opts)
   (values
-    (compile-expr expr)
+    (let* ((bind (make-bindings))
+           (loc (location expr))
+           (compiled (compile-expr bind expr)))
+      (make-sequence loc
+        `(,@(map-fluids-needed bind (lambda (mod sym)
+                                      (generate-ensure-fluid loc sym mod)))
+          ,compiled)))
     env
     env))