[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Chicken-hackers] [PATCH 2/2] Try constant folding before installing
|
From: |
megane |
|
Subject: |
Re: [Chicken-hackers] [PATCH 2/2] Try constant folding before installing specializations |
|
Date: |
Sun, 31 Mar 2019 16:17:40 +0300 |
|
User-agent: |
mu4e 1.0; emacs 25.1.1 |
Peter Bex <address@hidden> writes:
> On Thu, Feb 28, 2019 at 10:15:50AM +0200, megane wrote:
>> Hi,
>>
>> Here's a small improvement to optimization. The commits should tell the
>> story. This might have performance implications.
>>
>> I'm thinking that maybe this should go on top of the pending type-error
>> patch-set. Conflicts in that one are a bigger hurdle than changing this
>> patch is.
>
> Could you rebase this one? It looks good, but git can't apply it to
> current master.
>
Here. There's an additional patch to fix the printing of folded
expressions.
>From 23262f8ae23ffa8788a464793c726aaa99653d41 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Thu, 28 Feb 2019 07:33:06 +0200
Subject: [PATCH 1/3] * support.scm (constant-form-eval): Simplify logic
Change the code so 'k' is only called from tail position.
This simplifies the handling of case where the apply call causes an
exception. In the old code, this would cause a call to 'k' from a
non-tail position with ok value of #f. This would be handled in the
optimizer by returning the original n1. This is returned to
constant-form-eval as the value for the results variable. This causes
the first cond clause to fire (the one with the TODO comment), and 'k'
is called again.
Also, remove the form and msg arguments to 'k' as those are not used.
---
optimizer.scm | 2 +-
support.scm | 12 ++++--------
2 files changed, 5 insertions(+), 9 deletions(-)
diff --git a/optimizer.scm b/optimizer.scm
index ad13240..6318fbf 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -215,7 +215,7 @@
(constant-form-eval
var
(cddr subs)
- (lambda (ok form result msg)
+ (lambda (ok result)
(cond ((not ok)
(unless odirty (set! dirty #f))
(set! broken-constant-nodes
diff --git a/support.scm b/support.scm
index 48616a8..c802880 100644
--- a/support.scm
+++ b/support.scm
@@ -1493,18 +1493,14 @@
;; op must have toplevel binding, result must be single-valued
(let ((proc (##sys#slot op 0)))
(if (procedure? proc)
- (let ((results (handle-exceptions ex
- (k #f form #f
- (get-condition-property ex 'exn 'message))
- (receive (apply proc args)))))
- (cond ((node? results) ; TODO: This should not happen
- (k #f form #f #f))
+ (let ((results (handle-exceptions ex ex (receive (apply proc args)))))
+ (cond ((condition? results) (k #f #f))
((and (= 1 (length results))
(encodeable-literal? (car results)))
(debugging 'o "folded constant expression" form)
- (k #t form (car results) #f))
+ (k #t (car results)))
((= 1 (length results)) ; not encodeable; don't fold
- (k #f form #f #f))
+ (k #f #f))
(else
(bomb "attempt to constant-fold call to procedure that has
multiple results" form))))
(bomb "attempt to constant-fold call to non-procedure" form)))))
--
2.7.4
>From 0c1ac0ec6aa5df06b63fd96f695870fd40e5edec Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Thu, 28 Feb 2019 09:52:31 +0200
Subject: [PATCH 2/3] 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
---
optimizer.scm | 44 +++++++++++++++++------------------------
scrutinizer.scm | 12 ++++++++++-
support.scm | 14 ++++++++++++-
tests/scrutiny.expected | 6 +++---
tests/specialization-test-1.scm | 6 ++++--
tests/typematch-tests.scm | 2 ++
6 files changed, 51 insertions(+), 33 deletions(-)
diff --git a/optimizer.scm b/optimizer.scm
index 6318fbf..8ad3258 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 0816e02..60f0f04 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 c802880..44352e9 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 a16541c..2134026 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 52f72c3..42f6646 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 231207f..ac2d447 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)
--
2.7.4
>From 7b9b55a99d9f450197652df50b48ea09f08dde43 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Sun, 31 Mar 2019 16:04:49 +0300
Subject: [PATCH 3/3] Try to print original expressions harder in type messages
* tests/scrutiny.expected: Here the original expression was
(+ (+ (+ (+ 3))))
which was incorrectly printed as fully folded 3.
* scrutinizer.scm (source-node-tree): Calling source-node for
sub-expressions only handles one level. Call source-node-tree
recursively instead.
---
scrutinizer.scm | 2 +-
tests/scrutiny.expected | 4 ++--
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 60f0f04..7ceb830 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1719,7 +1719,7 @@
(lambda (n*)
(make-node (node-class n*)
(node-parameters n*)
- (map source-node (node-subexpressions n*))))))
+ (map source-node-tree (node-subexpressions n*))))))
(define (node-line-number n)
(node-debug-info (source-node n)))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 2134026..2396a53 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -30,7 +30,7 @@ Warning: Branch values mismatch
In procedure `foo',
In conditional expression:
- (if x (scheme#values 1 2) (scheme#values 1 2 3))
+ (if x (scheme#values 1 2) (scheme#values 1 2 (scheme#+ (scheme#+ ...))))
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#+ 3))
+ (scheme#values 1 2 (scheme#+ (scheme#+ (scheme#+ ...))))
Warning: Invalid argument
In file `scrutiny-tests.scm:XXX',
--
2.7.4