test-suite/tests/cse.test

   1 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
   2 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
   3 ;;;;
   4 ;;;;    Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-suite tree-il)
  21   #:use-module (test-suite lib)
  22   #:use-module (system base compile)
  23   #:use-module (system base pmatch)
  24   #:use-module (system base message)
  25   #:use-module (language tree-il)
  26   #:use-module (language tree-il canonicalize)
  27   #:use-module (language tree-il primitives)
  28   #:use-module (language tree-il fix-letrec)
  29   #:use-module (language tree-il cse)
  30   #:use-module (language tree-il peval)
  31   #:use-module (srfi srfi-13))
  32
  33 (define-syntax pass-if-cse
  34   (syntax-rules ()
  35     ((_ in pat)
  36      (pass-if 'in
  37        (let ((evaled (unparse-tree-il
  38                       (canonicalize
  39                        (fix-letrec
  40                         (cse
  41                          (peval
  42                           (expand-primitives
  43                            (resolve-primitives
  44                             (compile 'in #:from 'scheme #:to 'tree-il)
  45                             (current-module))))))))))
  46          (pmatch evaled
  47            (pat #t)
  48            (_   (pk 'cse-mismatch)
  49                 ((@ (ice-9 pretty-print) pretty-print)
  50                  'in)
  51                 (newline)
  52                 ((@ (ice-9 pretty-print) pretty-print)
  53                  evaled)
  54                 (newline)
  55                 ((@ (ice-9 pretty-print) pretty-print)
  56                  'pat)
  57                 (newline)
  58                 #f)))))))
  59
  60 \f
  61 (with-test-prefix "cse"
  62
  63   ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is
  64   ;; boolean-valued.
  65   (pass-if-cse
  66    (lambda (x y)
  67       (and (eq? x y)
  68            (eq? x y)))
  69     (lambda _
  70      (lambda-case
  71       (((x y) #f #f #f () (_ _))
  72        (primcall eq? (lexical x _) (lexical y _))))))
  73
  74   ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
  75   (pass-if-cse
  76    (lambda (x y)
  77       (if (eq? x y) #f #t))
  78     (lambda _
  79      (lambda-case
  80       (((x y) #f #f #f () (_ _))
  81        (primcall not
  82                  (primcall eq? (lexical x _) (lexical y _)))))))
  83
  84   ;; (if TEST (not TEST) #f)
  85   ;; => (if TEST #f #f)
  86   ;; => (begin TEST #f)
  87   ;; => #f
  88   (pass-if-cse
  89     (lambda (x y)
  90       (and (eq? x y) (not (eq? x y))))
  91     (lambda _
  92      (lambda-case
  93       (((x y) #f #f #f () (_ _))
  94        (const #f)))))
  95
  96   ;; (if TEST #f TEST) => (if TEST #f #f) => ...
  97   (pass-if-cse
  98    (lambda (x y)
  99       (if (eq? x y) #f (eq? x y)))
 100     (lambda _
 101      (lambda-case
 102       (((x y) #f #f #f () (_ _))
 103        (const #f)))))
 104
 105   ;; The same, but side-effecting primitives do not propagate.
 106   (pass-if-cse
 107    (lambda (x y)
 108       (and (set-car! x y) (not (set-car! x y))))
 109     (lambda _
 110      (lambda-case
 111       (((x y) #f #f #f () (_ _))
 112        (if (primcall set-car!
 113                      (lexical x _)
 114                      (lexical y _))
 115            (primcall not
 116                      (primcall set-car!
 117                                (lexical x _)
 118                                (lexical y _)))
 119            (const #f))))))
 120
 121   ;; Primitives that access mutable memory can propagate, as long as
 122   ;; there is no intervening mutation.
 123   (pass-if-cse
 124     (lambda (x y)
 125       (and (string-ref x y)
 126            (begin
 127              (string-ref x y)
 128              (not (string-ref x y)))))
 129     (lambda _
 130      (lambda-case
 131       (((x y) #f #f #f () (_ _))
 132        (seq (primcall string-ref
 133                       (lexical x _)
 134                       (lexical y _))
 135             (const #f))))))
 136
 137   ;; However, expressions with dependencies on effects do not propagate
 138   ;; through a lambda.
 139   (pass-if-cse
 140     (lambda (x y)
 141       (and (string-ref x y)
 142            (lambda ()
 143              (and (string-ref x y) #t))))
 144     (lambda _
 145      (lambda-case
 146       (((x y) #f #f #f () (_ _))
 147        (if (primcall string-ref
 148                      (lexical x _)
 149                      (lexical y _))
 150            (lambda _
 151              (lambda-case
 152               ((() #f #f #f () ())
 153                (if (primcall string-ref
 154                              (lexical x _)
 155                              (lexical y _))
 156                    (const #t)
 157                    (const #f)))))
 158            (const #f))))))
 159
 160   ;; A mutation stops the propagation.
 161   (pass-if-cse
 162     (lambda (x y)
 163       (and (string-ref x y)
 164            (begin
 165              (string-set! x #\!)
 166              (not (string-ref x y)))))
 167     (lambda _
 168      (lambda-case
 169       (((x y) #f #f #f () (_ _))
 170        (if (primcall string-ref
 171                      (lexical x _)
 172                      (lexical y _))
 173            (seq (primcall string-set!
 174                           (lexical x _)
 175                           (const #\!))
 176                 (primcall not
 177                           (primcall string-ref
 178                                     (lexical x _)
 179                                     (lexical y _))))
 180            (const #f))))))
 181
 182   ;; Predicates are only added to the database if they are in a
 183   ;; predicate context.
 184   (pass-if-cse
 185     (lambda (x y)
 186       (begin (eq? x y) (eq? x y)))
 187     (lambda _
 188      (lambda-case
 189       (((x y) #f #f #f () (_ _))
 190        (primcall eq? (lexical x _) (lexical y _))))))
 191
 192   ;; Conditional bailouts do cause primitives to be added to the DB.
 193   (pass-if-cse
 194     (lambda (x y)
 195       (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
 196     (lambda _
 197      (lambda-case
 198       (((x y) #f #f #f () (_ _))
 199        (seq (if (primcall eq?
 200                           (lexical x _) (lexical y _))
 201                 (void)
 202                 (primcall throw (const foo)))
 203             (const #t))))))
 204
 205   ;; A chain of tests in a conditional bailout add data to the DB
 206   ;; correctly.
 207   (pass-if-cse
 208     (lambda (x y)
 209       (begin
 210         (unless (and (struct? x) (eq? (struct-vtable x) x-vtable))
 211           (throw 'foo))
 212         (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
 213             (struct-ref x y)
 214             (throw 'bar))))
 215     (lambda _
 216      (lambda-case
 217       (((x y) #f #f #f () (_ _))
 218        (seq
 219          (fix (failure) (_)
 220               ((lambda _
 221                  (lambda-case
 222                   ((() #f #f #f () ())
 223                    (primcall throw (const foo))))))
 224               (if (primcall struct? (lexical x _))
 225                   (if (primcall eq?
 226                                 (primcall struct-vtable (lexical x _))
 227                                 (toplevel x-vtable))
 228                       (void)
 229                       (call (lexical failure _)))
 230                   (call (lexical failure _))))
 231          (primcall struct-ref (lexical x _) (lexical y _)))))))
 232
 233   ;; Strict argument evaluation also adds info to the DB.
 234   (pass-if-cse
 235     (lambda (x)
 236       ((lambda (z)
 237          (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
 238                   (struct-ref x 2)
 239                   (throw 'bar))))
 240        (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
 241            (struct-ref x 1)
 242            (throw 'foo))))
 243
 244     (lambda _
 245       (lambda-case
 246        (((x) #f #f #f () (_))
 247         (let (z) (_)
 248              ((fix (failure) (_)
 249                    ((lambda _
 250                       (lambda-case
 251                        ((() #f #f #f () ())
 252                         (primcall throw (const foo))))))
 253                    (if (primcall struct? (lexical x _))
 254                        (if (primcall eq?
 255                                      (primcall struct-vtable (lexical x _))
 256                                      (toplevel x-vtable))
 257                            (primcall struct-ref (lexical x _) (const 1))
 258                            (call (lexical failure _)))
 259                        (call (lexical failure _)))))
 260              (primcall + (lexical z _)
 261                        (primcall struct-ref (lexical x _) (const 2))))))))
 262
 263   ;; Replacing named expressions with lexicals.
 264   (pass-if-cse
 265    (let ((x (car y)))
 266      (cons x (car y)))
 267    (let (x) (_) ((primcall car (toplevel y)))
 268         (primcall cons (lexical x _) (lexical x _))))
 269
 270   ;; Dominating expressions only provide predicates when evaluated in
 271   ;; test context.
 272   (pass-if-cse
 273    (let ((t (car x)))
 274      (if (car x)
 275          'one
 276          'two))
 277    ;; Actually this one should reduce in other ways, but this is the
 278    ;; current reduction:
 279    (seq
 280      (primcall car (toplevel x))
 281      (if (primcall car (toplevel x))
 282          (const one)
 283          (const two))))
 284
 285   (pass-if-cse
 286    (begin (cons 1 2 3) 4)
 287    (seq
 288      (primcall cons (const 1) (const 2) (const 3))
 289      (const 4)))
 290
 291   (pass-if "http://bugs.gnu.org/12883"
 292     ;; In 2.0.6, compiling this code would trigger an out-of-bounds
 293     ;; vlist access in CSE's traversal of its "database".
 294     (procedure?
 295      (compile '(lambda (v)
 296                  (let ((failure (lambda () (bail-out 'match))))
 297                    (if (and (pair? v)
 298                             (null? (cdr v)))
 299                        (let ((w foo)
 300                              (x (cdr w)))
 301                          (if (and (pair? x) (null? w))
 302                              #t
 303                              (failure)))
 304                        (failure))))
 305               #:from 'scheme))))