From 3bfd411f09e3c38d6260076ed3d43a525618dd13 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.

Conflicts:
	core.scm
---
 core.scm        | 22 +++++++++++++---------
 scrutinizer.scm | 22 ++++++++++++++++++++++
 2 files changed, 35 insertions(+), 9 deletions(-)

diff --git a/core.scm b/core.scm
index d3c4c6c..fab584e 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 94c3b3f..cb7300f 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)))
-- 
2.1.4