From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 9 Nov 2001 21:37:55 +0000 (+0000)
Subject: Implement substitution optimizer, which does a kind of data-flow
X-Git-Tag: 20090517-FFI~2456
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e3cc9201aec5a75420dd34ebdef4ac4fbe689c40;p=mit-scheme.git

Implement substitution optimizer, which does a kind of data-flow
analysis to eliminate unnecessary lambda expressions.
---

diff --git a/v7/src/star-parser/load.scm b/v7/src/star-parser/load.scm
index 4cb2b87c2..3b0900087 100644
--- a/v7/src/star-parser/load.scm
+++ b/v7/src/star-parser/load.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: load.scm,v 1.10 2001/10/15 17:01:03 cph Exp $
+;;; $Id: load.scm,v 1.11 2001/11/09 21:37:51 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -23,4 +23,4 @@
 (with-working-directory-pathname (directory-pathname (current-load-pathname))
   (lambda ()
     (package/system-loader "parser" '() 'QUERY)))
-(add-subsystem-identification! "*Parser" '(0 9))
\ No newline at end of file
+(add-subsystem-identification! "*Parser" '(0 10))
\ No newline at end of file
diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index d6bb09694..cf14763ba 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.19 2001/10/16 17:52:28 cph Exp $
+;;; $Id: matcher.scm,v 1.20 2001/11/09 21:37:53 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -189,14 +189,14 @@
     (optimize-expression (generate-matcher-code expression))))
 
 (define (generate-matcher-code expression)
-  (generate-external-procedure expression
-			       preprocess-matcher-expression
-			       (lambda (expression)
-				 `(,(compile-matcher-expression expression #f)
-				   (LAMBDA (KF) KF #T)
-				   (LAMBDA () #F)))))
-
-(define (compile-matcher-expression expression pointer)
+  (generate-external-procedure expression preprocess-matcher-expression
+    (lambda (expression)
+      (bind-delayed-lambdas
+       (lambda (ks kf) (compile-matcher-expression expression #f ks kf))
+       (make-matcher-ks-lambda (lambda (kf) kf `#T))
+       (make-kf-lambda (lambda () `#F))))))
+
+(define (compile-matcher-expression expression pointer ks kf)
   (cond ((and (pair? expression)
 	      (symbol? (car expression))
 	      (list? (cdr expression))
@@ -206,21 +206,29 @@
 		    (compiler (cdr entry)))
 		(if (and arity (not (= (length (cdr expression)) arity)))
 		    (error "Incorrect arity for matcher:" expression))
-		(apply compiler pointer (cdr expression)))))
+		(apply compiler pointer ks kf (cdr expression)))))
 	((or (symbol? expression)
 	     (and (pair? expression) (eq? (car expression) 'SEXP)))
-	 (wrap-external-matcher
-	  `(,(if (pair? expression) (cadr expression) expression)
-	    ,*buffer-name*)))
+	 (wrap-external-matcher `((PROTECT ,(if (pair? expression)
+						(cadr expression)
+						expression))
+				  ,*buffer-name*)
+				ks
+				kf))
 	(else
 	 (error "Malformed matcher:" expression))))
 
+(define (wrap-external-matcher matcher ks kf)
+  `(IF ,matcher
+       ,(delay-call ks kf)
+       ,(delay-call kf)))
+
 (define-macro (define-matcher form . compiler-body)
   (let ((name (car form))
 	(parameters (cdr form)))
     `(DEFINE-MATCHER-COMPILER ',name
        ,(if (symbol? parameters) `#F (length parameters))
-       (LAMBDA (POINTER . ,parameters)
+       (LAMBDA (POINTER KS KF . ,parameters)
 	 ,@compiler-body))))
 
 (define (define-matcher-compiler keyword arity compiler)
@@ -233,89 +241,94 @@
 (define-macro (define-atomic-matcher form test-expression)
   `(DEFINE-MATCHER ,form
      POINTER
-     (WRAP-EXTERNAL-MATCHER ,test-expression)))
+     (WRAP-EXTERNAL-MATCHER ,test-expression KS KF)))
 
 (define-atomic-matcher (char char)
-  `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* ,char))
+  `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* (PROTECT ,char)))
 
 (define-atomic-matcher (char-ci char)
-  `(MATCH-PARSER-BUFFER-CHAR-CI ,*buffer-name* ,char))
+  `(MATCH-PARSER-BUFFER-CHAR-CI ,*buffer-name* (PROTECT ,char)))
 
 (define-atomic-matcher (not-char char)
-  `(MATCH-PARSER-BUFFER-NOT-CHAR ,*buffer-name* ,char))
+  `(MATCH-PARSER-BUFFER-NOT-CHAR ,*buffer-name* (PROTECT ,char)))
 
 (define-atomic-matcher (not-char-ci char)
-  `(MATCH-PARSER-BUFFER-NOT-CHAR-CI ,*buffer-name* ,char))
+  `(MATCH-PARSER-BUFFER-NOT-CHAR-CI ,*buffer-name* (PROTECT ,char)))
 
 (define-atomic-matcher (char-set char-set)
-  `(MATCH-PARSER-BUFFER-CHAR-IN-SET ,*buffer-name* ,char-set))
+  `(MATCH-PARSER-BUFFER-CHAR-IN-SET ,*buffer-name* (PROTECT ,char-set)))
 
 (define-atomic-matcher (alphabet alphabet)
-  `(MATCH-UTF8-CHAR-IN-ALPHABET ,*buffer-name* ,alphabet))
+  `(MATCH-UTF8-CHAR-IN-ALPHABET ,*buffer-name* (PROTECT ,alphabet)))
 
 (define-atomic-matcher (string string)
-  `(MATCH-PARSER-BUFFER-STRING ,*buffer-name* ,string))
+  `(MATCH-PARSER-BUFFER-STRING ,*buffer-name* (PROTECT ,string)))
 
 (define-atomic-matcher (string-ci string)
-  `(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* ,string))
+  `(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* (PROTECT ,string)))
 
 (define-atomic-matcher (end-of-input)
-  `(NOT (PEEK-PARSER-BUFFER-CHAR ,*BUFFER-NAME*)))
+  `(NOT (PEEK-PARSER-BUFFER-CHAR ,*buffer-name*)))
 
 (define-matcher (discard-matched)
   pointer
-  (wrap-matcher
-   (lambda (ks kf)
-     `(BEGIN
-	(DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
-	(,ks ,kf)))))
+  `(BEGIN
+     (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
+     ,(delay-call ks kf)))
 
 (define-matcher (with-pointer identifier expression)
-  `(LET ((,identifier ,(or pointer (fetch-pointer))))
-     ,(compile-matcher-expression expression (or pointer identifier))))
+  `((LAMBDA (,identifier)
+      ,(compile-matcher-expression expression identifier ks kf))
+    ,(fetch-pointer)))
 
 (define-matcher (seq . expressions)
   (if (pair? expressions)
       (if (pair? (cdr expressions))
-	  (wrap-matcher
-	   (lambda (ks kf)
-	     (let loop ((expressions expressions) (pointer pointer) (kf2 kf))
-	       `(,(compile-matcher-expression (car expressions) pointer)
-		 ,(if (pair? (cdr expressions))
-		      (let ((kf3 (make-kf-identifier)))
-			`(LAMBDA (,kf3)
-			   ,(loop (cdr expressions) #f kf3)))
-		      ks)
-		 ,kf2))))
-	  (compile-matcher-expression (car expressions) pointer))
-      (wrap-matcher (lambda (ks kf) `(,ks ,kf)))))
+	  (let loop ((expressions expressions) (pointer pointer) (kf kf))
+	    (if (pair? (cdr expressions))
+		(bind-delayed-lambdas
+		 (lambda (ks)
+		   (compile-matcher-expression (car expressions)
+					       pointer
+					       ks
+					       kf))
+		 (make-matcher-ks-lambda
+		  (lambda (kf)
+		    (loop (cdr expressions) #f kf))))
+		(compile-matcher-expression (car expressions) pointer ks kf)))
+	  (compile-matcher-expression (car expressions) pointer ks kf))
+      (delay-call ks kf)))
 
 (define-matcher (alt . expressions)
   (if (pair? expressions)
       (if (pair? (cdr expressions))
-	  (wrap-matcher
-	   (lambda (ks kf)
-	     (let loop ((expressions expressions) (pointer pointer))
-	       `(,(compile-matcher-expression (car expressions) pointer)
-		 ,ks
-		 ,(if (pair? (cdr expressions))
-		      (backtracking-kf pointer
-			(lambda (pointer)
-			  (loop (cdr expressions) pointer)))
-		      kf)))))
-	  (compile-matcher-expression (car expressions) pointer))
-      (wrap-matcher (lambda (ks kf) `(BEGIN ,ks (,kf))))))
+	  (let loop ((expressions expressions) (pointer pointer))
+	    (if (pair? (cdr expressions))
+		(call-with-pointer pointer
+		  (lambda (pointer)
+		    (bind-delayed-lambdas
+		     (lambda (kf)
+		       (compile-matcher-expression (car expressions)
+						   pointer
+						   ks
+						   kf))
+		     (backtracking-kf pointer
+		       (lambda ()
+			 (loop (cdr expressions) pointer))))))
+		(compile-matcher-expression (car expressions) pointer ks kf)))
+	  (compile-matcher-expression (car expressions) pointer ks kf))
+      (delay-call kf)))
 
 (define-matcher (* expression)
   pointer
-  (wrap-matcher
-   (lambda (ks kf)
-     (let ((ks2 (make-ks-identifier))
-	   (kf2 (make-kf-identifier)))
-       `(LET ,ks2 ((,kf2 ,kf))
-	  (,(compile-matcher-expression expression #f)
-	   ,ks2
-	   ,(backtracking-kf #f
-	      (lambda (pointer)
-		pointer
-		`(,ks ,kf2)))))))))
\ No newline at end of file
+  (let ((ks2 (make-ks-identifier))
+	(kf2 (make-kf-identifier)))
+    `(LET ,ks2 ((,kf2 ,(delay-reference kf)))
+       ,(call-with-pointer #f
+	  (lambda (pointer)
+	    (bind-delayed-lambdas
+	     (lambda (kf)
+	       (compile-matcher-expression expression #f ks2 kf))
+	     (backtracking-kf pointer
+	       (lambda ()
+		 (delay-call ks kf2)))))))))
\ No newline at end of file
diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index a79baca0f..b5d9b1cc6 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.22 2001/10/16 17:52:31 cph Exp $
+;;; $Id: parser.scm,v 1.23 2001/11/09 21:37:55 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -178,14 +178,14 @@
     (optimize-expression (generate-parser-code expression))))
 
 (define (generate-parser-code expression)
-  (generate-external-procedure expression
-			       preprocess-parser-expression
-			       (lambda (expression)
-				 `(,(compile-parser-expression expression #f)
-				   (LAMBDA (V KF) KF V)
-				   (LAMBDA () #F)))))
-
-(define (compile-parser-expression expression pointer)
+  (generate-external-procedure expression preprocess-parser-expression
+    (lambda (expression)
+      (bind-delayed-lambdas
+       (lambda (ks kf) (compile-parser-expression expression #f ks kf))
+       (make-parser-ks-lambda (lambda (v kf) kf v))
+       (make-kf-lambda (lambda () #f))))))
+
+(define (compile-parser-expression expression pointer ks kf)
   (cond ((and (pair? expression)
 	      (symbol? (car expression))
 	      (list? (cdr expression))
@@ -195,21 +195,31 @@
 		    (compiler (cdr entry)))
 		(if (and arity (not (= (length (cdr expression)) arity)))
 		    (error "Incorrect arity for parser:" expression))
-		(apply compiler pointer (cdr expression)))))
+		(apply compiler pointer ks kf (cdr expression)))))
 	((or (symbol? expression)
 	     (and (pair? expression) (eq? (car expression) 'SEXP)))
-	 (wrap-external-parser
-	  `(,(if (pair? expression) (cadr expression) expression)
-	    ,*buffer-name*)))
+	 (wrap-external-parser `((PROTECT ,(if (pair? expression)
+					       (cadr expression)
+					       expression))
+				 ,*buffer-name*)
+			       ks
+			       kf))
 	(else
 	 (error "Malformed parser:" expression))))
 
+(define (wrap-external-parser expression ks kf)
+  (with-value-binding expression
+    (lambda (v)
+      `(IF ,v
+	   ,(delay-call ks v kf)
+	   ,(delay-call kf)))))
+
 (define-macro (define-parser form . compiler-body)
   (let ((name (car form))
 	(parameters (cdr form)))
     `(DEFINE-PARSER-COMPILER ',name
        ,(if (symbol? parameters) `#F (length parameters))
-       (LAMBDA (POINTER . ,parameters)
+       (LAMBDA (POINTER KS KF . ,parameters)
 	 ,@compiler-body))))
 
 (define (define-parser-compiler keyword arity compiler)
@@ -220,121 +230,125 @@
   (make-eq-hash-table))
 
 (define-parser (match expression)
-  (wrap-parser
-   (lambda (ks kf)
-     (call-with-pointer pointer
-       (lambda (p)
-	 `(,(compile-matcher-expression expression p)
-	   ,(let ((kf2 (make-kf-identifier)))
-	      `(LAMBDA (,kf2)
-		 (,ks (VECTOR (GET-PARSER-BUFFER-TAIL ,*buffer-name* ,p))
-		      ,kf2)))
-	   ,kf))))))
+  (call-with-pointer pointer
+    (lambda (pointer)
+      (bind-delayed-lambdas
+       (lambda (ks)
+	 (compile-matcher-expression expression pointer ks kf))
+       (make-matcher-ks-lambda
+	(lambda (kf)
+	  (delay-call ks
+		      `(VECTOR
+			(GET-PARSER-BUFFER-TAIL ,*buffer-name* ,pointer))
+		      kf)))))))
 
 (define-parser (noise expression)
-  (wrap-parser
-   (lambda (ks kf)
-     `(,(compile-matcher-expression expression pointer)
-       ,(let ((kf2 (make-kf-identifier)))
-	  `(LAMBDA (,kf2)
-	     (,ks '#() ,kf2)))
-       ,kf))))
+  (bind-delayed-lambdas
+   (lambda (ks)
+     (compile-matcher-expression expression pointer ks kf))
+   (make-matcher-ks-lambda
+     (lambda (kf)
+       (delay-call ks `(VECTOR) kf)))))
 
 (define-parser (values . expressions)
   pointer
-  (wrap-parser
-   (lambda (ks kf)
-     `(,ks (VECTOR ,@expressions) ,kf))))
+  (delay-call ks
+	      `(VECTOR ,@(map (lambda (expression)
+				`(PROTECT ,expression))
+			      expressions))
+	      kf))
 
 (define-parser (transform transform expression)
-  (post-processed-parser expression pointer
+  (post-processed-parser expression pointer ks kf
     (lambda (ks v kf)
-      (handle-parser-value `(,transform ,v) ks kf))))
+      (wrap-external-parser `((PROTECT ,transform) ,v) ks kf))))
 
 (define-parser (map transform expression)
-  (post-processed-parser expression pointer
+  (post-processed-parser expression pointer ks kf
     (lambda (ks v kf)
-      `(,ks (VECTOR-MAP ,transform ,v) ,kf))))
+      (delay-call ks `(VECTOR-MAP (PROTECT ,transform) ,v) kf))))
 
 (define-parser (encapsulate transform expression)
-  (post-processed-parser expression pointer
+  (post-processed-parser expression pointer ks kf
     (lambda (ks v kf)
-      `(,ks (VECTOR (,transform ,v)) ,kf))))
-
-(define (post-processed-parser expression pointer procedure)
-  (wrap-parser
-   (lambda (ks kf)
-     `(,(compile-parser-expression expression pointer)
-       ,(let ((v (make-value-identifier))
-	      (kf2 (make-kf-identifier)))
-	  `(LAMBDA (,v ,kf2)
-	     ,(procedure ks v kf2)))
-       ,kf))))
+      (delay-call ks `(VECTOR ((PROTECT ,transform) ,v)) kf))))
+
+(define (post-processed-parser expression pointer ks kf procedure)
+  (bind-delayed-lambdas
+   (lambda (ks)
+     (compile-parser-expression expression pointer ks kf))
+   (make-parser-ks-lambda
+    (lambda (v kf)
+      (procedure ks v kf)))))
 
 (define-parser (with-pointer identifier expression)
-  `(LET ((,identifier ,(or pointer (fetch-pointer))))
-     ,(compile-parser-expression expression (or pointer identifier))))
+  `((LAMBDA (,identifier)
+      ,(compile-parser-expression expression identifier ks kf))
+    ,(fetch-pointer)))
 
 (define-parser (discard-matched)
   pointer
-  (wrap-parser
-   (lambda (ks kf)
-     `(BEGIN
-	(DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
-	(,ks '#() ,kf)))))
+  `(BEGIN
+     (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
+     ,(delay-call ks `(VECTOR) kf)))
 
 (define-parser (seq . expressions)
   (if (pair? expressions)
       (if (pair? (cdr expressions))
-	  (wrap-parser
-	   (lambda (ks kf)
-	     (let loop
-		 ((expressions expressions)
-		  (pointer pointer)
-		  (vs '())
-		  (kf2 kf))
-	       `(,(compile-parser-expression (car expressions) pointer)
-		 ,(let ((v (make-value-identifier))
-			(kf3 (make-kf-identifier)))
-		    `(LAMBDA (,v ,kf3)
-		       ,(let ((vs (cons v vs)))
-			  (if (pair? (cdr expressions))
-			      (loop (cdr expressions) #f vs kf3)
-			      `(,ks (VECTOR-APPEND ,@(reverse vs)) ,kf3)))))
-		 ,kf2))))
-	  (compile-parser-expression (car expressions) pointer))
-      (wrap-parser (lambda (ks kf) `(,ks '#() ,kf)))))
+	  (let loop
+	      ((expressions expressions)
+	       (pointer pointer)
+	       (vs '())
+	       (kf kf))
+	    (bind-delayed-lambdas
+	     (lambda (ks)
+	       (compile-parser-expression (car expressions) pointer ks kf))
+	     (make-parser-ks-lambda
+	      (lambda (v kf)
+		(let ((vs (cons v vs)))
+		  (if (pair? (cdr expressions))
+		      (loop (cdr expressions) #f vs kf)
+		      (delay-call ks `(VECTOR-APPEND ,@(reverse vs)) kf)))))))
+	  (compile-parser-expression (car expressions) pointer ks kf))
+      (delay-call ks `(VECTOR) kf)))
 
 (define-parser (alt . expressions)
   (if (pair? expressions)
       (if (pair? (cdr expressions))
-	  (wrap-parser
-	   (lambda (ks kf)
-	     (let loop ((expressions expressions) (pointer pointer))
-	       `(,(compile-parser-expression (car expressions) pointer)
-		 ,ks
-		 ,(if (pair? (cdr expressions))
-		      (backtracking-kf pointer
-			(lambda (pointer)
-			  (loop (cdr expressions) pointer)))
-		      kf)))))
-	  (compile-parser-expression (car expressions)))
-      (wrap-parser (lambda (ks kf) ks `(,kf)))))
+	  (let loop ((expressions expressions) (pointer pointer))
+	    (if (pair? (cdr expressions))
+		(call-with-pointer pointer
+		  (lambda (pointer)
+		    (bind-delayed-lambdas
+		     (lambda (kf)
+		       (compile-parser-expression (car expressions)
+						  pointer
+						  ks
+						  kf))
+		     (backtracking-kf pointer
+		       (lambda ()
+			 (loop (cdr expressions) pointer))))))
+		(compile-parser-expression (car expressions)
+					   pointer
+					   ks
+					   kf)))
+	  (compile-parser-expression (car expressions) ks kf))
+      (delay-call kf)))
 
 (define-parser (* expression)
   pointer
-  (wrap-parser
-   (lambda (ks kf)
-     (let ((ks2 (make-ks-identifier))
-	   (v (make-value-identifier))
-	   (kf2 (make-kf-identifier)))
-       `(LET ,ks2 ((,v '#()) (,kf2 ,kf))
-	  (,(compile-parser-expression expression #f)
-	   ,(let ((v2 (make-value-identifier))
-		  (kf3 (make-kf-identifier)))
-	      `(LAMBDA (,v2 ,kf3)
-		 (,ks2 (VECTOR-APPEND ,v ,v2) ,kf3)))
-	   ,(backtracking-kf #f
-	      (lambda (pointer)
-		pointer
-		`(,ks ,v ,kf2)))))))))
\ No newline at end of file
+  (let ((ks2 (make-ks-identifier))
+	(v (make-value-identifier))
+	(kf2 (make-kf-identifier)))
+    `(LET ,ks2 ((,v (VECTOR)) (,kf2 ,kf))
+       ,(call-with-pointer #f
+	  (lambda (pointer)
+	    (bind-delayed-lambdas
+	     (lambda (ks kf)
+	       (compile-parser-expression expression pointer ks kf))
+	     (make-parser-ks-lambda
+	      (lambda (v2 kf)
+		(delay-call ks2 `(VECTOR-APPEND ,v ,(delay-reference v2)) kf)))
+	     (backtracking-kf pointer
+	       (lambda ()
+		 (delay-call ks v kf2)))))))))
\ No newline at end of file