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        (primcall 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        (primcall not
  79                  (primcall 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 (primcall set-car!
 110                      (lexical x _)
 111                      (lexical y _))
 112            (primcall not
 113                      (primcall 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        (seq (primcall string-ref
 130                       (lexical x _)
 131                       (lexical y _))
 132             (const #f))))))
 133
 134   ;; However, expressions with dependencies on effects do not propagate
 135   ;; through a lambda.
 136   (pass-if-cse
 137     (lambda (x y)
 138       (and (string-ref x y)
 139            (lambda ()
 140              (and (string-ref x y) #t))))
 141     (lambda _
 142      (lambda-case
 143       (((x y) #f #f #f () (_ _))
 144        (if (primcall string-ref
 145                      (lexical x _)
 146                      (lexical y _))
 147            (lambda _
 148              (lambda-case
 149               ((() #f #f #f () ())
 150                (if (primcall string-ref
 151                              (lexical x _)
 152                              (lexical y _))
 153                    (const #t)
 154                    (const #f)))))
 155            (const #f))))))
 156
 157   ;; A mutation stops the propagation.
 158   (pass-if-cse
 159     (lambda (x y)
 160       (and (string-ref x y)
 161            (begin
 162              (string-set! x #\!)
 163              (not (string-ref x y)))))
 164     (lambda _
 165      (lambda-case
 166       (((x y) #f #f #f () (_ _))
 167        (if (primcall string-ref
 168                      (lexical x _)
 169                      (lexical y _))
 170            (seq (primcall string-set!
 171                           (lexical x _)
 172                           (const #\!))
 173                 (primcall not
 174                           (primcall string-ref
 175                                     (lexical x _)
 176                                     (lexical y _))))
 177            (const #f))))))
 178
 179   ;; Predicates are only added to the database if they are in a
 180   ;; predicate context.
 181   (pass-if-cse
 182     (lambda (x y)
 183       (begin (eq? x y) (eq? x y)))
 184     (lambda _
 185      (lambda-case
 186       (((x y) #f #f #f () (_ _))
 187        (primcall eq? (lexical x _) (lexical y _))))))
 188
 189   ;; Conditional bailouts do cause primitives to be added to the DB.
 190   (pass-if-cse
 191     (lambda (x y)
 192       (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
 193     (lambda _
 194      (lambda-case
 195       (((x y) #f #f #f () (_ _))
 196        (seq (if (primcall eq?
 197                           (lexical x _) (lexical y _))
 198                 (void)
 199                 (primcall throw (const foo)))
 200             (const #t))))))
 201
 202   ;; A chain of tests in a conditional bailout add data to the DB
 203   ;; correctly.
 204   (pass-if-cse
 205     (lambda (x y)
 206       (begin
 207         (unless (and (struct? x) (eq? (struct-vtable x) x-vtable))
 208           (throw 'foo))
 209         (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
 210             (struct-ref x y)
 211             (throw 'bar))))
 212     (lambda _
 213      (lambda-case
 214       (((x y) #f #f #f () (_ _))
 215        (seq (if (if (primcall struct? (lexical x _))
 216                     (primcall eq?
 217                               (primcall struct-vtable
 218                                         (lexical x _))
 219                               (toplevel x-vtable))
 220                     (const #f))
 221                 (void)
 222                 (primcall throw (const foo)))
 223             (primcall struct-ref (lexical x _) (lexical y _)))))))
 224
 225   ;; Strict argument evaluation also adds info to the DB.
 226   (pass-if-cse
 227     (lambda (x)
 228       ((lambda (z)
 229          (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
 230                   (struct-ref x 2)
 231                   (throw 'bar))))
 232        (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
 233            (struct-ref x 1)
 234            (throw 'foo))))
 235
 236     (lambda _
 237       (lambda-case
 238        (((x) #f #f #f () (_))
 239         (let (z) (_) ((if (if (primcall struct? (lexical x _))
 240                               (primcall eq?
 241                                         (primcall struct-vtable
 242                                                   (lexical x _))
 243                                         (toplevel x-vtable))
 244                               (const #f))
 245                           (primcall struct-ref (lexical x _) (const 1))
 246                           (primcall throw (const foo))))
 247              (primcall + (lexical z _)
 248                        (primcall struct-ref (lexical x _) (const 2))))))))
 249
 250   ;; Replacing named expressions with lexicals.
 251   (pass-if-cse
 252    (let ((x (car y)))
 253      (cons x (car y)))
 254    (let (x) (_) ((primcall car (toplevel y)))
 255         (primcall cons (lexical x _) (lexical x _)))))