From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Sat, 28 Jan 1995 17:13:24 +0000 (+0000)
Subject: Added a hook to see what constant folding we are missing.
X-Git-Tag: 20090517-FFI~6696
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=27a3036cd8d930a37616c89c7b0059b57af2172c;p=mit-scheme.git

Added a hook to see what constant folding we are missing.
Only operates if COMPILER:GURU? is true.
---

diff --git a/v8/src/compiler/midend/cleanup.scm b/v8/src/compiler/midend/cleanup.scm
index 292d9feee..66e4eb44d 100644
--- a/v8/src/compiler/midend/cleanup.scm
+++ b/v8/src/compiler/midend/cleanup.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: cleanup.scm,v 1.4 1995/01/22 17:13:24 adams Exp $
+$Id: cleanup.scm,v 1.5 1995/01/28 17:13:24 adams Exp $
 
 Copyright (c) 1994 Massachusetts Institute of Technology
 
@@ -43,12 +43,17 @@ MIT in each case. |#
 (define-macro (define-cleanup-handler keyword bindings . body)
   (let ((proc-name (symbol-append 'CLEANUP/ keyword)))
     (call-with-values
-     (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
-     (lambda (names code)
-       `(DEFINE ,proc-name
-	  (LET ((HANDLER (LAMBDA ,(cons (car bindings) names) ,@body)))
-	    (NAMED-LAMBDA (,proc-name ENV FORM)
-	      (CLEANUP/REMEMBER ,code FORM))))))))
+	(lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
+      (lambda (names code)
+	`(DEFINE ,proc-name
+	   (LET ((HANDLER (LAMBDA ,(cons (car bindings) names) ,@body)))
+	     (NAMED-LAMBDA (,proc-name ENV FORM)
+	       (LET ((TRANSFORM-CODE (LAMBDA () ,code)))
+		 (LET ((INFO (CLEANUP/GET-DBG-INFO ENV FORM)))
+		   (LET ((CODE (TRANSFORM-CODE)))
+		     (IF INFO
+			 (CODE-REWRITE/REMEMBER* CODE INFO))
+		     CODE))))))))))
 
 (define-cleanup-handler LOOKUP (env name)
   (let ((place (assq name env)))
@@ -121,9 +126,17 @@ MIT in each case. |#
 
 (define-cleanup-handler CALL (env rator cont #!rest rands)
   (define (default)
-    `(CALL ,(cleanup/expr env rator)
-           ,(cleanup/expr env cont)
-           ,@(cleanup/expr* env rands)))
+    (let* ((rator* (cleanup/expr env rator))
+	   (result
+	    `(CALL ,rator*
+		   ,(cleanup/expr env cont)
+		   ,@(cleanup/expr* env rands))))
+      (and compiler:guru?
+	   (QUOTE/? rator*)
+	   (for-all? (cddr result) QUOTE/?)
+	   (hash-table/get *cleanup/delta-rewriters* (QUOTE/text rator*) 'BAD)
+	   (internal-warning "Missed delta:" result))
+      result))
   (cond ((LAMBDA/? rator)
          (let ((lambda-list (lambda/formals rator))
                (lambda-body (lambda/body rator)))
@@ -188,6 +201,28 @@ MIT in each case. |#
                  (else
                   call*))))))
 
+
+(define *cleanup/delta-rewriters* (make-eq-hash-table))
+(for-each (lambda (item)
+	    (hash-table/put! *cleanup/delta-rewriters* item #F))
+	  (list cons
+		%cons
+		%fetch-continuation
+		%fetch-environment
+		%fetch-stack-closure
+		%make-cell
+		%make-read-variable-cache
+		%make-write-variable-cache
+		%make-operator-variable-cache
+		%make-remote-operator-variable-cache
+		vector
+		%vector
+		%vector-cons
+		%floating-vector-cons
+		string-allocate
+		%string-allocate
+		%vector-index))
+
 (define (cleanup/call/maybe-flush-closure call* env match-result)
   (let ((lambda-expr    (cadr (assq cleanup/?lam-expr match-result)))
 	(cont           (cadr (assq cleanup/?cont match-result)))
@@ -458,4 +493,30 @@ MIT in each case. |#
 	exprs))
 
 (define (cleanup/remember new old)
-  (code-rewrite/remember new old))
\ No newline at end of file
+  (code-rewrite/remember new old))
+
+(define (cleanup/get-dbg-info env expr)
+  (cond ((code-rewrite/original-form/previous expr)
+         => (lambda (dbg-info)
+              ;; Copy the dbg info, rewriting the expressions
+              (let* ((block     (new-dbg-form/block dbg-info))
+                     (block*    (new-dbg-block/copy-transforming
+                                 (lambda (expr)
+                                   (cleanup/copy-dbg-kmp expr env))
+                                 block))
+                     (dbg-info* (new-dbg-form/new-block dbg-info block*)))
+                dbg-info*)))
+        (else #F)))
+
+
+(define (cleanup/copy-dbg-kmp expr env)
+  (form/copy-transforming
+   (lambda (form copy uninteresting)
+     copy
+     (cond ((and (LOOKUP/? form)
+		 (assq (lookup/name form) env))
+	    => (lambda (place)
+		 (form/copy (cadr place))))
+	   (else
+	    (uninteresting form))))
+   expr))