chicken-hackers
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Chicken-hackers] [PATCH 2/2] Try constant folding before installing spe


From: megane
Subject: [Chicken-hackers] [PATCH 2/2] Try constant folding before installing specializations
Date: Thu, 28 Feb 2019 10:15:50 +0200
User-agent: mu4e 1.0; emacs 25.1.1

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.


Cheers

>From 2672fe0808f42810d195a865a8c3187158599e8e Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Thu, 28 Feb 2019 07:33:06 +0200
Subject: [PATCH 1/2] * 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 9e9d2685d4fd490c45b0130fe71eae0a948f5d7f Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Thu, 28 Feb 2019 09:52:31 +0200
Subject: [PATCH 2/2] 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         |  4 ++--
 tests/specialization-test-1.scm |  6 ++++--
 tests/typematch-tests.scm       |  2 ++
 6 files changed, 50 insertions(+), 32 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 a8c8b3d..bca40a2 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -445,6 +445,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))
@@ -475,7 +482,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))))
@@ -774,6 +782,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 e445ebb..26819e1 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -4,7 +4,7 @@ Warning: (scrutiny-tests.scm:31) - assignment to imported value 
binding `car'
 Note: in local procedure `c',
   in local procedure `b',
   in toplevel procedure `a':
-  expected a value of type boolean in conditional, but was given a value of 
type `number' which is always true:
+  expected a value of type boolean in conditional, but was given a value of 
type `fixnum' which is always true:
 
 (if x 1 2)
 
@@ -16,7 +16,7 @@ Note: in toplevel procedure `b':
 Warning: in toplevel procedure `foo':
   branches in conditional expression differ in the number of results:
 
-(if x (scheme#values 1 2) (scheme#values 1 2 (scheme#+ (scheme#+ ...))))
+(if x (scheme#values 1 2) (scheme#values 1 2 3))
 
 Warning: at toplevel:
   (scrutiny-tests.scm:19) in procedure call to `bar', expected argument #2 of 
type `number' but was given an argument of type `symbol'
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


reply via email to

[Prev in Thread] Current Thread [Next in Thread]