~ chicken-core (chicken-5) 1ec315982093f39a7945fabb00a2daf1aa23189c

commit 1ec315982093f39a7945fabb00a2daf1aa23189c
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Sep 6 20:30:53 2010 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Sep 6 20:30:53 2010 +0200

    cfolding done via apply

diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 91c1ecff..7fdc13d7 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -59,6 +59,7 @@
  compiler-syntax-enabled
  compiler-syntax-statistics
  compute-database-statistics
+ constant-form-eval
  constant-table
  constant?
  constants-used
diff --git a/optimizer.scm b/optimizer.scm
index 0b225971..06b150a9 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -167,7 +167,7 @@
 		  (subs (node-subexpressions n1)) )
 	     (case (node-class n1)
 
-	       ((if)			; (This can be done by the simplificator...)
+	       ((if)			; (This can be done by the simplifier...)
 		(cond ((constant-node? (car subs))
 		       (set! removed-ifs (+ removed-ifs 1))
 		       (touch)
@@ -183,20 +183,24 @@
 		      (if (and (intrinsic? var)
 			       (foldable? var)
 			       (every constant-node? (cddr subs)) )
-			  (let ((form (cons var (map (lambda (arg) `(quote ,(node-value arg)))
-						     (cddr subs) ) ) ) )
-			    (handle-exceptions ex
-				(begin
-				  (unless odirty (set! dirty #f))
-				  (set! broken-constant-nodes (lset-adjoin eq? broken-constant-nodes n1))
-				  n1)
-			      (let ((x (eval form)))
-				(debugging 'o "folding constant expression" form)
-				(touch)
-				(make-node ; Build call to continuation with new result...
-				 '##core#call
-				 '(#t)
-				 (list (cadr subs) (qnode x)) ) ) ) )
+			  (constant-form-eval
+			   var
+			   (cddr subs)
+			   (lambda (ok form result)
+			     (cond ((not ok)
+				    (unless odirty (set! dirty #f))
+				    (set! broken-constant-nodes
+				      (lset-adjoin eq? broken-constant-nodes n1))
+				    n1)
+				   (else
+				    (touch)
+				    ;; Build call to continuation with new result...
+				    (let ((n2 (qnode result)))
+				      (register-cfold var (cddr subs) form n2)
+				      (make-node
+				       '##core#call
+				       '(#t)
+				       (list (cadr subs) n2) ) ) ) )))
 			  n1) )
 		    n1) )
 
diff --git a/support.scm b/support.scm
index 43bd2444..2edaeebe 100644
--- a/support.scm
+++ b/support.scm
@@ -451,6 +451,9 @@
   (parameters node-parameters node-parameters-set!) ; (value...)
   (subexpressions node-subexpressions node-subexpressions-set!)) ; (node...)
 
+(define-record-printer (node n out)
+  (fprintf out "#<node ~a>" (node-class n)))
+
 (define (make-node c p s)
   (##sys#make-structure 'node c p s) ) ; this kludge is for allowing the inlined `make-node'
 
@@ -1389,11 +1392,23 @@ EOF
       (and info (->string info))))
 
 
-;;; We need this for constant folding:
+;;; constant folding support:
 
 (define (string-null? x) 
   (##core#inline "C_i_string_null_p" s))
 
+(define (constant-form-eval op argnodes k)
+  (let* ((args (map (lambda (n) (first (node-parameters n))) argnodes))
+	 (form (cons op (map (lambda (arg) `(quote ,arg)) args))))
+    (handle-exceptions ex 
+	(begin
+	  (debugging 'o "folding constant expression failed" form)
+	  (k #f form #f))
+      ;; op must have toplevel binding, result must be single-valued
+      (let ((result (apply (##sys#slot op 0) args)))
+	(debugging 'o "folded constant expression" form)
+	(k #t form result)))))
+
 
 ;;; Dump node structure: