From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 14 Nov 2001 20:19:13 +0000 (+0000)
Subject: Fix some problems in the pointer optimization: pointers were being
X-Git-Tag: 20090517-FFI~2444
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3efe10bd8ebb7a138f8c16c8883e6489d7d7f430;p=mit-scheme.git

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 b9ac3502f..87f619a35 100644
--- 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))))
 
 (define-matcher (seq . expressions)
   (if (pair? expressions)
diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index 54bfef6aa..390d49b19 100644
--- 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 f37b5ef6a..dca6fa6f7 100644
--- 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))
-
+
 (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*)
 
@@ -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)