From 82dfb73da87c345bed38e4b784589b2657cf847f Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Sun, 26 Feb 1995 16:35:19 +0000
Subject: [PATCH] Added rewrite  (IF p p #F) ==> p  for simple & side effect
 free p.

This catches those nasty little `diamonds' produced in both earlyrew
and laterew for code such as (&+ x x).
---
 v8/src/compiler/midend/cleanup.scm | 42 +++++++++++++++---------------
 1 file changed, 21 insertions(+), 21 deletions(-)

diff --git a/v8/src/compiler/midend/cleanup.scm b/v8/src/compiler/midend/cleanup.scm
index 7b078b495..453278f56 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.8 1995/02/21 06:33:13 adams Exp $
+$Id: cleanup.scm,v 1.9 1995/02/26 16:35:19 adams Exp $
 
 Copyright (c) 1994 Massachusetts Institute of Technology
 
@@ -92,29 +92,29 @@ MIT in each case. |#
   `(DECLARE ,@anything))
 
 (define-cleanup-handler IF (env pred conseq alt)
-  (let ((pred* (cleanup/expr env pred)))
+  (let ((pred*    (cleanup/expr env pred))
+	(conseq*  (cleanup/expr env conseq))
+	(alt*     (cleanup/expr env alt)))
     (define (default)
-      `(IF ,pred* 
-	   ,(cleanup/expr env conseq)
-	   ,(cleanup/expr env alt)))
+      `(IF ,pred* ,conseq* ,alt*))
     (cond ((QUOTE/? pred*)
 	   (case (boolean/discriminate (quote/text pred*))
-	     ((FALSE)
-	      (cleanup/expr env alt))
-	     ((TRUE)
-	      (cleanup/expr env conseq))
-	     (else
-	      (default))))
-	  ((CALL/? pred*)
-	   ;; (if (not p) c a) => (if p a c)
-	   (let ((pred-rator (call/operator pred*)))
-	     (if (and (QUOTE/? pred-rator)
-		      (eq? (quote/text pred-rator) not)
-		      (equal? (call/continuation pred*) `(QUOTE #F)))
-		 `(IF ,(first (call/operands pred*))
-		      ,(cleanup/expr env alt)
-		      ,(cleanup/expr env conseq))
-		 (default))))
+	     ((FALSE)    alt*)
+	     ((TRUE)     conseq*)
+	     (else       (default))))
+	  (;; (if p p #F) => p    (Some generic arith diamonds)
+	   (and (equal? alt* '(QUOTE #F))
+		(equal? pred* conseq*)
+		(form/simple&side-effect-free? pred*))
+	   pred*)
+	  (;; (if (not p) c a) => (if p a c)
+	   (and (CALL/? pred*)
+		(QUOTE/? (call/operator pred*))
+		(eq? (quote/text (call/operator pred*)) not)
+		(equal? (call/continuation pred*) `(QUOTE #F)))
+	   `(IF ,(first (call/operands pred*))
+		,alt*
+		,conseq*))
 	  (else
 	   (default)))))
 
-- 
2.25.1