~ chicken-core (chicken-5) b8d143a8ae8a40158e584021c6aeba6a69a3b39d
commit b8d143a8ae8a40158e584021c6aeba6a69a3b39d
Author: megane <meganeka@gmail.com>
AuthorDate: Thu Feb 28 09:52:31 2019 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Mar 31 16:10:05 2019 +0200
Try constant folding before installing specializations
If specializations are enabled the compiler currently doesn't constant
simple expressions like this:
(+ 1 1)
Instead, this example is specialized to this:
(##core#inline_allocate ("C_a_i_fixnum_plus" 5) 1 1)
The optimizer cannot fold this.
This patch adds constant folding capability to the scrutinizer.
* tests/specialization-test-1.scm: Here (+) would get constant folded,
whereas (+ (foo)) does not.
Currently there's no guarantee specializations are installed at all.
So I think it's OK that folding may happen instead of
specialization, too.
User installed specializations still precede built-ins, which is
what the test is for.
* optimizer.scm: Moved the "is this node constant-foldable?"
-detection to support.scm
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/optimizer.scm b/optimizer.scm
index 6318fbf2..8ad32580 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -206,32 +206,24 @@
(else n1) ) )
((##core#call)
- (if (eq? '##core#variable (node-class (car subs)))
- (let ((var (first (node-parameters (car subs)))))
- (if (and (intrinsic? var)
- (or (foldable? var)
- (predicate? var))
- (every constant-node? (cddr subs)))
- (constant-form-eval
- var
- (cddr subs)
- (lambda (ok 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)))
- (make-node
- '##core#call
- (list #t)
- (list (cadr subs) n2) ) ) ) )))
- n1) )
- n1) )
-
+ (maybe-constant-fold-call
+ n1
+ (cons (car subs) (cddr subs))
+ (lambda (ok result constant?)
+ (cond ((not ok)
+ (when constant?
+ (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)))
+ (make-node
+ '##core#call
+ (list #t)
+ (list (cadr subs) n2) ) ) ) ))) )
(else n1) ) ) ) ) )
(define (replace-var var)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 0816e02d..60f0f04c 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -361,6 +361,13 @@
(set! r '(false))
(set! op (list pt `(not ,pt)))))
(else (trail-restore trail0 typeenv)))))
+ ((maybe-constant-fold-call node (node-subexpressions node)
+ (lambda (ok res _constant?)
+ (and ok (cons res ok))))
+ => (lambda (res.ok)
+ ;; Actual type doesn't matter; the node gets walked again
+ (set! r '*)
+ (mutate-node! node (list 'quote (car res.ok)))))
((and specialize (get-specializations pn)) =>
(lambda (specs)
(let loop ((specs specs))
@@ -391,7 +398,8 @@
(set! specialization-statistics
(cons (cons op 1)
specialization-statistics))))))
- (when (and specialize (not op) (procedure-type? ptype))
+ (when (and specialize (not op) (procedure-type? ptype)
+ (eq? '##core#call (node-class node)))
(set-car! (node-parameters node) #t)
(set! safe-calls (add1 safe-calls))))
(let ((r (if (eq? '* r) r (map (cut resolve <> typeenv) r))))
@@ -673,6 +681,8 @@
(if (eq? '* r)
r
(map (cut resolve <> typeenv) r)))
+ ((eq? 'quote (node-class n)) ; Call got constant folded
+ (walk n e loc dest tail flow ctags))
(else
(for-each
(lambda (arg argr)
diff --git a/support.scm b/support.scm
index c802880e..44352e98 100644
--- a/support.scm
+++ b/support.scm
@@ -65,7 +65,7 @@
clear-real-name-table! get-real-name set-real-name!
real-name real-name2 display-real-name-table
source-info->string source-info->line source-info->name
- call-info constant-form-eval
+ call-info constant-form-eval maybe-constant-fold-call
dump-nodes read-info-hook read/source-info big-fixnum? small-bignum?
hide-variable export-variable variable-hidden? variable-visible?
mark-variable variable-mark intrinsic? predicate? foldable?
@@ -1505,6 +1505,18 @@
(bomb "attempt to constant-fold call to procedure that has multiple results" form))))
(bomb "attempt to constant-fold call to non-procedure" form)))))
+(define (maybe-constant-fold-call n subs k)
+ (define (constant-node? n2) (eq? 'quote (node-class n2)))
+ (if (eq? '##core#variable (node-class (car subs)))
+ (let ((var (first (node-parameters (car subs)))))
+ (if (and (intrinsic? var)
+ (or (foldable? var)
+ (predicate? var))
+ (every constant-node? (cdr subs)) )
+ (constant-form-eval var (cdr subs) (lambda (ok res) (k ok res #t)))
+ (k #f #f #f)))
+ (k #f #f #f)))
+
;; Is the literal small enough to be encoded? Otherwise, it should
;; not be constant-folded.
(define (encodeable-literal? lit)
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index a16541c0..2134026c 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -13,7 +13,7 @@ Note: Test is always true
Test condition has always true value of type:
- number
+ fixnum
Note: Test is always true
In procedure `b',
@@ -30,7 +30,7 @@ Warning: Branch values mismatch
In procedure `foo',
In conditional expression:
- (if x (scheme#values 1 2) (scheme#values 1 2 (scheme#+ (scheme#+ ...))))
+ (if x (scheme#values 1 2) (scheme#values 1 2 3))
The branches have different numbers of values.
@@ -40,7 +40,7 @@ Warning: Branch values mismatch
The false branch returns 3 values:
- (scheme#values 1 2 (scheme#+ (scheme#+ (scheme#+ ...))))
+ (scheme#values 1 2 (scheme#+ 3))
Warning: Invalid argument
In file `scrutiny-tests.scm:XXX',
diff --git a/tests/specialization-test-1.scm b/tests/specialization-test-1.scm
index 52f72c30..42f6646b 100644
--- a/tests/specialization-test-1.scm
+++ b/tests/specialization-test-1.scm
@@ -69,7 +69,9 @@ return n;}
(assert (abc 1))
;; user-defined specializations take precedence over built-ins
-(define-specialization (+) 1)
-(assert (= (+) 1))
+(: foo (-> fixnum))
+(define (foo) (begin))
+(define-specialization (+ fixnum) fixnum 1)
+(assert (= (+ (foo)) 1))
)
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 231207f2..ac2d447c 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -425,4 +425,6 @@
((list 'a (forall (a) (list 'b a))) #f)
((list 'b (forall (b) (list b 'a))) #t)))
+(infer true (= 3 (+ 1 2))) ; Constant folding should happen before / during scrutiny
+
(test-exit)
Trap