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 primitives)
  27   #:use-module (language tree-il cse)
  28   #:use-module (language tree-il peval)
  29   #:use-module (language glil)
  30   #:use-module (srfi srfi-13))
  31
  32 (define-syntax pass-if-cse
  33   (syntax-rules ()
  34     ((_ in pat)
  35      (pass-if 'in
  36        (let ((evaled (unparse-tree-il
  37                       (cse
  38                        (peval
  39                         (expand-primitives!
  40                          (resolve-primitives!
  41                           (compile 'in #:from 'scheme #:to 'tree-il)
  42                           (current-module))))))))
  43          (pmatch evaled
  44            (pat #t)
  45            (_   (pk 'cse-mismatch)
  46                 ((@ (ice-9 pretty-print) pretty-print)
  47                  'in)
  48                 (newline)
  49                 ((@ (ice-9 pretty-print) pretty-print)
  50                  evaled)
  51                 (newline)
  52                 ((@ (ice-9 pretty-print) pretty-print)
  53                  'pat)
  54                 (newline)
  55                 #f)))))))
  56
  57 \f
  58 (with-test-prefix "cse"
  59
  60   ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is
  61   ;; boolean-valued.
  62   (pass-if-cse
  63    (lambda (x y)
  64       (and (eq? x y)
  65            (eq? x y)))
  66     (lambda _
  67      (lambda-case
  68       (((x y) #f #f #f () (_ _))
  69        (apply (primitive eq?) (lexical x _) (lexical y _))))))
  70
  71   ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
  72   (pass-if-cse
  73    (lambda (x y)
  74       (if (eq? x y) #f #t))
  75     (lambda _
  76      (lambda-case
  77       (((x y) #f #f #f () (_ _))
  78        (apply (primitive not)
  79               (apply (primitive eq?) (lexical x _) (lexical y _)))))))
  80
  81   ;; (if TEST (not TEST) #f)
  82   ;; => (if TEST #f #f)
  83   ;; => (begin TEST #f)
  84   ;; => #f
  85   (pass-if-cse
  86     (lambda (x y)
  87       (and (eq? x y) (not (eq? x y))))
  88     (lambda _
  89      (lambda-case
  90       (((x y) #f #f #f () (_ _))
  91        (const #f)))))
  92
  93   ;; (if TEST #f TEST) => (if TEST #f #f) => ...
  94   (pass-if-cse
  95    (lambda (x y)
  96       (if (eq? x y) #f (eq? x y)))
  97     (lambda _
  98      (lambda-case
  99       (((x y) #f #f #f () (_ _))
 100        (const #f)))))
 101
 102   ;; The same, but side-effecting primitives do not propagate.
 103   (pass-if-cse
 104    (lambda (x y)
 105       (and (set-car! x y) (not (set-car! x y))))
 106     (lambda _
 107      (lambda-case
 108       (((x y) #f #f #f () (_ _))
 109        (if (apply (primitive set-car!)
 110                   (lexical x _)
 111                   (lexical y _))
 112            (apply (primitive not)
 113                   (apply (primitive set-car!)
 114                          (lexical x _)
 115                          (lexical y _)))
 116            (const #f))))))
 117
 118   ;; Primitives that access mutable memory can propagate, as long as
 119   ;; there is no intervening mutation.
 120   (pass-if-cse
 121     (lambda (x y)
 122       (and (string-ref x y)
 123            (begin
 124              (string-ref x y)
 125              (not (string-ref x y)))))
 126     (lambda _
 127      (lambda-case
 128       (((x y) #f #f #f () (_ _))
 129        (begin
 130          (apply (primitive string-ref)
 131                 (lexical x _)
 132                 (lexical y _))
 133          (const #f))))))
 134
 135   ;; However, expressions with dependencies on effects do not propagate
 136   ;; through a lambda.
 137   (pass-if-cse
 138     (lambda (x y)
 139       (and (string-ref x y)
 140            (lambda ()
 141              (and (string-ref x y) #t))))
 142     (lambda _
 143      (lambda-case
 144       (((x y) #f #f #f () (_ _))
 145        (if (apply (primitive string-ref)
 146                   (lexical x _)
 147                   (lexical y _))
 148            (lambda _
 149              (lambda-case
 150               ((() #f #f #f () ())
 151                (if (apply (primitive string-ref)
 152                           (lexical x _)
 153                           (lexical y _))
 154                    (const #t)
 155                    (const #f)))))
 156            (const #f))))))
 157
 158   ;; A mutation stops the propagation.
 159   (pass-if-cse
 160     (lambda (x y)
 161       (and (string-ref x y)
 162            (begin
 163              (string-set! x #\!)
 164              (not (string-ref x y)))))
 165     (lambda _
 166      (lambda-case
 167       (((x y) #f #f #f () (_ _))
 168        (if (apply (primitive string-ref)
 169                   (lexical x _)
 170                   (lexical y _))
 171            (begin
 172              (apply (primitive string-set!)
 173                     (lexical x _)
 174                     (const #\!))
 175              (apply (primitive not)
 176                     (apply (primitive string-ref)
 177                            (lexical x _)
 178                            (lexical y _))))
 179            (const #f))))))
 180
 181   ;; Predicates are only added to the database if they are in a
 182   ;; predicate context.
 183   (pass-if-cse
 184     (lambda (x y)
 185       (begin (eq? x y) (eq? x y)))
 186     (lambda _
 187      (lambda-case
 188       (((x y) #f #f #f () (_ _))
 189        (apply (primitive eq?) (lexical x _) (lexical y _))))))
 190
 191   ;; Conditional bailouts do cause primitives to be added to the DB.
 192   (pass-if-cse
 193     (lambda (x y)
 194       (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
 195     (lambda _
 196      (lambda-case
 197       (((x y) #f #f #f () (_ _))
 198        (begin
 199          (if (apply (primitive eq?)
 200                     (lexical x _) (lexical y _))
 201              (void)
 202              (apply (primitive '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        (begin
 219          (if (if (apply (primitive struct?) (lexical x _))
 220                  (apply (primitive eq?)
 221                         (apply (primitive struct-vtable)
 222                                (lexical x _))
 223                         (toplevel x-vtable))
 224                  (const #f))
 225              (void)
 226              (apply (primitive 'throw) (const 'foo)))
 227          (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
 228
 229   ;; Strict argument evaluation also adds info to the DB.
 230   (pass-if-cse
 231     (lambda (x)
 232       ((lambda (z)
 233          (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
 234                   (struct-ref x 2)
 235                   (throw 'bar))))
 236        (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
 237            (struct-ref x 1)
 238            (throw 'foo))))
 239
 240     (lambda _
 241       (lambda-case
 242        (((x) #f #f #f () (_))
 243         (let (z) (_) ((if (if (apply (primitive struct?) (lexical x _))
 244                               (apply (primitive eq?)
 245                                      (apply (primitive struct-vtable)
 246                                             (lexical x _))
 247                                      (toplevel x-vtable))
 248                               (const #f))
 249                           (apply (primitive struct-ref) (lexical x _) (const 1))
 250                           (apply (primitive 'throw) (const 'foo))))
 251              (apply (primitive +) (lexical z _)
 252                     (apply (primitive struct-ref) (lexical x _) (const 2)))))))))