From: Joe Marshall <eval.apply@gmail.com>
Date: Sat, 14 Jan 2012 19:33:16 +0000 (-0800)
Subject: Suppress redundant type checks in generated pattern matching code.
X-Git-Tag: release-9.2.0~334^2~25
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=505c52e85a99e3eb012cc597519238fc57f7871f;p=mit-scheme.git

Suppress redundant type checks in generated pattern matching code.
---

diff --git a/src/compiler/base/pmlook.scm b/src/compiler/base/pmlook.scm
index 6e1bf30f1..52c31d5d0 100644
--- a/src/compiler/base/pmlook.scm
+++ b/src/compiler/base/pmlook.scm
@@ -108,17 +108,19 @@ USA.
 	(r-null?   (close-syntax 'NULL? environment))
 	(r-pair?   (close-syntax 'PAIR? environment))
 	(r-quote   (close-syntax 'QUOTE environment)))
-    (let descend ((pattern pattern)
+    (let descend ((top-level #t)
+		  (pattern pattern)
 		  (body `(,body ,@(pattern-variables pattern))))
       (if (pair? pattern)
 	  (if (eq? (car pattern) pattern-variable-tag)
 	      `(,r-lambda (,(cdr pattern)) ,body)
 	      (let ((instance (generate-uninterned-symbol)))
 		`(,r-lambda (,instance)
+			    ,@(if top-level `((,r-declare (NO-TYPE-CHECKS))) '())
 			    (,r-and (,r-pair? ,instance)
-				    (,(descend (car pattern)
-					    `(,(descend (cdr pattern) body)
-					      (,r-cdr ,instance)))
+				    (,(descend #f (car pattern)
+					       `(,(descend #f (cdr pattern) body)
+						 (,r-cdr ,instance)))
 				     (,r-car ,instance))))))
 	  (let ((instance (generate-uninterned-symbol)))
 	    `(,r-lambda (,instance)
diff --git a/src/compiler/base/pmpars.scm b/src/compiler/base/pmpars.scm
index fd15e9598..641c46f1b 100644
--- a/src/compiler/base/pmpars.scm
+++ b/src/compiler/base/pmpars.scm
@@ -108,7 +108,7 @@ USA.
 				     environment)
 	     environment))))
 
-(define compile-pattern-matchers? #f)
+(define compile-pattern-matchers? #t)
 
 (define (make-rule-matcher pattern expression environment)
   ;; PATTERN-LOOKUP-2 and the compiled matchers require that there
@@ -144,7 +144,9 @@ USA.
 				 ,@qualifiers
 				 (,r-lambda () ,body)))))
       `(,r-lambda ,outer-vars
-	  (,(close-syntax 'DECLARE environment) (INTEGRATE ,@outer-vars))
+	  (,(close-syntax 'DECLARE environment)
+	   (INTEGRATE ,@outer-vars)
+	   (TYPE-CHECKS))
 	  ,(if (and (null? inner-vars)
 		    (null? xforms))
 	       qualified-body