~ chicken-core (chicken-5) bbfc758f50ce4c87dbc770aabe2574597e2956cf

commit bbfc758f50ce4c87dbc770aabe2574597e2956cf
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Fri Jul 8 19:30:58 2016 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Fri Jul 8 19:30:58 2016 +0200

    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/core.scm b/core.scm
index d3c4c6cc..806d7cff 100644
--- a/core.scm
+++ b/core.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>...]
@@ -1839,11 +1839,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))
@@ -2519,11 +2521,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)
@@ -2545,7 +2548,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)
@@ -2805,6 +2808,7 @@
 			   (blockvar (not (variable-visible?
 					   var block-compilation)))
 			   (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
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 94c3b3fc..083d5eb8 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -161,6 +161,7 @@
 	(aliased '())
 	(noreturn #f)
 	(dropped-branches 0)
+	(assigned-immediates 0)
 	(errors #f)
 	(safe-calls 0))
 
@@ -260,6 +261,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)
 	  '*
@@ -694,6 +709,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)
@@ -870,6 +890,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-compiling "some variable types do not satisfy strictness"))
       rn)))