From 32b6929dfcc630508bae44fe8ee570f0274143d3 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Fri, 8 Jul 2016 19:30:58 +0200
Subject: [PATCH 1/4] 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.
---
 compiler.scm    | 34 +++++++++++++++++++---------------
 scrutinizer.scm | 22 ++++++++++++++++++++++
 2 files changed, 41 insertions(+), 15 deletions(-)

diff --git a/compiler.scm b/compiler.scm
index 26486c5..a78d06b 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 f03b51e..9b00c75 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)))
-- 
2.1.4