Fix some problems in the pointer optimization: pointers were being

incorrect elided across lambda expressions, and external pointer
bindings were being elided.  The latter is fixed by introducing a
mechanism to distinguish internal identifiers, which eliminates the
need for the WITH-POINTER kludge.

diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index b9ac3502f72a9cda72f184fa51de38247657bcc2..87f619a3573f3dbf5dc9d4796da09b38e65342a6 100644 (file)
--- a/v7/src/star-parser/matcher.scm
+++ b/v7/src/star-parser/matcher.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: matcher.scm,v 1.23 2001/11/14 18:15:16 cph Exp $
+;;; $Id: matcher.scm,v 1.24 2001/11/14 20:18:35 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -277,12 +277,9 @@
      ,(delay-call ks kf)))
 
 (define-matcher (with-pointer identifier expression)
-  pointer
-  ;; Ignore the POINTER context.  This is a kludge that prevents the
-  ;; binding of IDENTIFIER from being discarded by the optimizer.
   `((LAMBDA (,identifier)
-      ,(compile-matcher-expression expression identifier ks kf))
-    ,(fetch-pointer)))
+      ,(compile-matcher-expression expression (or pointer identifier) ks kf))
+    ,(or pointer (fetch-pointer))))
 \f
 (define-matcher (seq . expressions)
   (if (pair? expressions)

diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index 54bfef6aa5df40a941e597a021a3390e516f6aa8..390d49b19feb0f0a1ee86eba557d66e6e2876335 100644 (file)
--- a/v7/src/star-parser/parser.scm
+++ b/v7/src/star-parser/parser.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: parser.scm,v 1.26 2001/11/14 18:15:31 cph Exp $
+;;; $Id: parser.scm,v 1.27 2001/11/14 20:19:13 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -282,12 +282,9 @@
       (procedure ks v kf)))))
 
 (define-parser (with-pointer identifier expression)
-  pointer
-  ;; Ignore the POINTER context.  This is a kludge that prevents the
-  ;; binding of IDENTIFIER from being discarded by the optimizer.
   `((LAMBDA (,identifier)
-      ,(compile-parser-expression expression identifier ks kf))
-    ,(fetch-pointer)))
+      ,(compile-parser-expression expression (or pointer identifier) ks kf))
+    ,(or pointer (fetch-pointer))))
 
 (define-parser (discard-matched)
   pointer

diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm
index f37b5ef6af477ba27bb9c7c0eca91062f39f9206..dca6fa6f78d5abac6b34538262d8726ee533b779 100644 (file)
--- a/v7/src/star-parser/shared.scm
+++ b/v7/src/star-parser/shared.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: shared.scm,v 1.18 2001/11/14 18:27:17 cph Exp $
+;;; $Id: shared.scm,v 1.19 2001/11/14 20:16:45 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -252,7 +252,7 @@
   (make-delayed-lambda make-ks-identifier
                       (list make-value-identifier make-kf-identifier)
                       generator))
-
+\f
 (define (make-kf-identifier)
   (generate-identifier 'KF))
 
@@ -268,6 +268,7 @@
 (define (generate-identifier prefix)
   (string->uninterned-symbol
    (string-append
+    internal-identifier-prefix
     (symbol-name prefix)
     (number->string
      (let ((entry (assq prefix *id-counters*)))
@@ -277,7 +278,16 @@
             n)
           (begin
             (set! *id-counters* (cons (cons prefix 2) *id-counters*))
-            1)))))))
+            1))))
+    internal-identifier-suffix)))
+
+(define (internal-identifier? identifier)
+  (let ((string (symbol-name identifier)))
+    (and (string-prefix? internal-identifier-prefix string)
+        (string-suffix? internal-identifier-suffix string))))
+
+(define internal-identifier-prefix "#[")
+(define internal-identifier-suffix "]")
  
 (define *id-counters*)
 \f
@@ -410,6 +420,7 @@
              (operand (car operands))
              (count (car counts)))
          (cond ((and (= 0 count)
+                     (internal-identifier? identifier)
                      (operand-discardable? operand))
                 (loop (cdr identifiers)
                       (cdr operands)
@@ -606,8 +617,7 @@
 
 (define (operand-discardable? operand)
   ;; Returns true iff OPERAND can be removed from the program,
-  ;; provided that its value is unused.  Basically this tests for the
-  ;; potential presence of side effects in OPERAND.
+  ;; provided that its value is unused.
   (not (expression-may-have-side-effects? operand)))
 
 (define (expression-may-have-side-effects? expression)
@@ -661,10 +671,7 @@
        ((eq? (car expression) 'LAMBDA)
         (let ((parameters (cadr expression)))
           `(LAMBDA ,parameters
-             ,(optimize-pointer-usage (caddr expression)
-                                      (if (memq pointer parameters)
-                                          #f
-                                          pointer)))))
+             ,(optimize-pointer-usage (caddr expression) #f))))
        ((eq? (car expression) 'LET)
         (let ((name (cadr expression))
               (bindings
@@ -689,11 +696,24 @@
                        expression)
         (let ((operator (car expression))
               (operand (cadr expression)))
-          (let ((parameter (car (cadr operator))))
-            (let ((body (optimize-pointer-usage (caddr operator) parameter)))
-              (if (> (car (count-references (list parameter) body)) 0)
-                  `((LAMBDA (,parameter) ,body) ,operand)
-                  body)))))
+          (let ((identifier (car (cadr operator))))
+            (let ((body (optimize-pointer-usage (caddr operator) identifier)))
+              (if (and (internal-identifier? identifier)
+                       (= (car (count-references (list identifier) body)) 0))
+                  body
+                  `((LAMBDA (,identifier) ,body) ,operand))))))
+       ((syntax-match? '(('LAMBDA (* IDENTIFIER) EXPRESSION)
+                         . (* EXPRESSION))
+                       expression)
+        (let ((operator (car expression))
+              (operands (cdr expression)))
+          (let ((parameters (cadr operator)))
+            `((LAMBDA ,parameters
+                ,(optimize-pointer-usage (caddr operator)
+                                         (if (memq pointer parameters)
+                                             #f
+                                             pointer)))
+              ,@operands))))
        ((syntax-match?
          '('BEGIN
             ('SET-PARSER-BUFFER-POINTER! EXPRESSION IDENTIFIER)