~ chicken-core (chicken-5) 9dc2592cc09bf337474b1c765806163790be1747

commit 9dc2592cc09bf337474b1c765806163790be1747
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Fri Jul 8 19:30:58 2016 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jul 24 11:50:39 2016 +1200

    Do not track set! to known-to-be-immediate values.
    
    This extends the core language by adding an optional second param to the
    internal core version of set!, which gets filled in by the scrutinizer
    whenever the set! value is determined to always be immediate.
    
    In tight loops where set! is called very often it might make a
    difference.  On our benchmarks it doesn't make a dent in the results,
    though.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/compiler.scm b/compiler.scm
index 26486c57..db1b0b21 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -158,7 +158,7 @@
 ; [quote {<exp>}]
 ; [let {<variable>} <exp-v> <exp>]
 ; [##core#lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
-; [set! {<variable>} <exp>]
+; [set! {<variable> [always-immediate?]} <exp>]
 ; [##core#undefined {}]
 ; [##core#primitive {<name>}]
 ; [##core#inline {<op>} <exp>...]
@@ -1759,11 +1759,13 @@
                                       (list (car vars))
                                       (list r (loop (cdr vars) (cdr vals))) )) ) ) ) ) )
 	((lambda ##core#lambda) (cps-lambda (gensym-f-id) (first params) subs k))
-	((set!) (let ((t1 (gensym 't)))
+	((set!) (let* ((t1 (gensym 't))
+		       (immediate? (and (pair? (cdr params)) (cadr params)))
+		       (new-params (list (first params) immediate?)))
 		  (walk (car subs)
 			(lambda (r)
 			  (make-node 'let (list t1)
-				     (list (make-node 'set! (list (first params)) (list r))
+				     (list (make-node 'set! new-params (list r))
 					   (k (varnode t1)) ) ) ) ) ) )
 	((##core#foreign-callback-wrapper)
 	 (let ([id (gensym-f-id)]
@@ -2448,11 +2450,12 @@
 			  cvars) ) ) ) ) ) ) ) )
 
 	  ((set!)
-	   (let* ([var (first params)]
-		  [val (first subs)]
-		  [cval (node-class val)]
-		  [immf (or (and (eq? 'quote cval) (immediate? (first (node-parameters val))))
-			    (eq? '##core#undefined cval) ) ] )
+	   (let* ((var (first params))
+		  (val (first subs))
+		  (cval (node-class val))
+		  (immf (or (and (eq? 'quote cval) (immediate? (first (node-parameters val))))
+			    (and (pair? (cdr params)) (second params))
+			    (eq? '##core#undefined cval))))
 	     (cond ((posq var closure)
 		    => (lambda (i)
 			 (if (test var 'boxed)
@@ -2474,7 +2477,7 @@
 		     (list (varnode var)
 			   (transform val here closure) ) ) )
 		   (else (make-node
-			  'set! (list var)
+			  'set! (list var immf)
 			  (list (transform val here closure) ) ) ) ) ) )
 
 	  ((##core#primitive) 
@@ -2713,18 +2716,19 @@
 		    (walk (second subs) e e-count here boxes) ) ) ) )
 
 	  ((set!)
-	   (let ([var (first params)]
-		 [val (first subs)] )
+	   (let ((var (first params))
+		 (val (first subs)))
 	     (cond ((posq var e)
 		    => (lambda (i)
                          (make-node '##core#setlocal
                                     (list (fx- e-count (fx+ i 1)))
                                     (list (walk val e e-count here boxes)) ) ) )
 		   (else
-		    (let* ([cval (node-class val)]
-			   [blockvar (not (variable-visible? var))]
-			   [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
-				     (eq? '##core#undefined cval) ) ] )
+		    (let* ((cval (node-class val))
+			   (blockvar (not (variable-visible? var)))
+			   (immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
+				     (and (pair? (cdr params)) (second params))
+				     (eq? '##core#undefined cval))))
 		      (when blockvar (set! fastsets (add1 fastsets)))
 		      (make-node
 		       (if immf '##core#setglobal_i '##core#setglobal)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index f03b51eb..f05fffe1 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -130,6 +130,7 @@
 	(aliased '())
 	(noreturn #f)
 	(dropped-branches 0)
+	(assigned-immediates 0)
 	(errors #f)
 	(safe-calls 0))
 
@@ -225,6 +226,20 @@
 	 (node-source-prefix test-node) (pp-fragment if-node))
 	#t))
 
+    (define (always-immediate1 t)
+      (cond ((pair? t)
+	     (case (car t)
+	       ((or) (every always-immediate1 (cdr t)))
+	       ((forall) (always-immediate1 (third t)))
+	       (else #f)))
+	    ((memq t '(eof null fixnum char boolean undefined)) #t)
+	    (else #f)))
+
+    (define (always-immediate var t loc)
+      (and-let* ((_ (always-immediate1 t)))
+	(d "assignment to var ~a in ~a is always immediate" var loc)
+	#t))
+
     (define (single node what tv loc)
       (if (eq? '* tv)
 	  '*
@@ -676,6 +691,11 @@
 				   (set-cdr! (car bl) t)
 				   (loop (cdr bl) (eq? fl (cdaar bl)))))
 				(else (loop (cdr bl) f))))))
+
+		    (when (always-immediate var rt loc)
+		      (set! assigned-immediates (add1 assigned-immediates))
+		      (set-cdr! params '(#t)))
+
 		    '(undefined)))
 		 ((##core#primitive ##core#inline_ref) '*)
 		 ((##core#call)
@@ -865,6 +885,8 @@
 	(debugging '(o e) "safe calls" safe-calls))
       (when (positive? dropped-branches)
 	(debugging '(o e) "dropped branches" dropped-branches))
+      (when (positive? assigned-immediates)
+	(debugging '(o e) "assignments to immediate values" assigned-immediates))
       (when errors
 	(quit "some variable types do not satisfy strictness"))
       rn)))