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