test-suite/tests/tree-il.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 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 (language tree-il)
  25   #:use-module (language glil))
  26
  27 ;; Of course, the GLIL that is emitted depends on the source info of the
  28 ;; input. Here we're not concerned about that, so we strip source
  29 ;; information from the incoming tree-il.
  30
  31 (define (strip-source x)
  32   (post-order! (lambda (x) (set! (tree-il-src x) #f))
  33                x))
  34
  35 (define-syntax assert-scheme->glil
  36   (syntax-rules ()
  37     ((_ in out)
  38      (let ((tree-il (strip-source
  39                      (compile 'in #:from 'scheme #:to 'tree-il))))
  40        (pass-if 'in
  41                 (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
  42                         'out))))))
  43
  44 (define-syntax assert-tree-il->glil
  45   (syntax-rules ()
  46     ((_ in out)
  47      (pass-if 'in
  48               (let ((tree-il (strip-source (parse-tree-il 'in))))
  49                 (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
  50                         'out))))))
  51
  52 (define-syntax assert-tree-il->glil/pmatch
  53   (syntax-rules ()
  54     ((_ in pat test ...)
  55      (let ((exp 'in))
  56        (pass-if 'in
  57          (let ((glil (unparse-glil
  58                       (compile (strip-source (parse-tree-il exp))
  59                                #:from 'tree-il #:to 'glil))))
  60            (pmatch glil
  61              (pat (guard test ...) #t)
  62              (else #f))))))))
  63
  64 (with-test-prefix "void"
  65   (assert-tree-il->glil
  66    (void)
  67    (program 0 0 0 0 () (void) (call return 1)))
  68   (assert-tree-il->glil
  69    (begin (void) (const 1))
  70    (program 0 0 0 0 () (const 1) (call return 1)))
  71   (assert-tree-il->glil
  72    (apply (primitive +) (void) (const 1))
  73    (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
  74
  75 (with-test-prefix "application"
  76   (assert-tree-il->glil
  77    (apply (toplevel foo) (const 1))
  78    (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
  79   (assert-tree-il->glil/pmatch
  80    (begin (apply (toplevel foo) (const 1)) (void))
  81    (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
  82             (call drop 1) (branch br ,l2)
  83             (label ,l3) (mv-bind () #f) (unbind)
  84             (label ,l4)
  85             (void) (call return 1))
  86    (and (eq? l1 l3) (eq? l2 l4)))
  87   (assert-tree-il->glil
  88    (apply (toplevel foo) (apply (toplevel bar)))
  89    (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
  90             (call goto/args 1))))
  91
  92 (with-test-prefix "conditional"
  93   (assert-tree-il->glil/pmatch
  94    (if (const #t) (const 1) (const 2))
  95    (program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
  96             (const 1) (call return 1)
  97             (label ,l2) (const 2) (call return 1))
  98    (eq? l1 l2))
  99
 100   (assert-tree-il->glil/pmatch
 101    (begin (if (const #t) (const 1) (const 2)) (const #f))
 102    (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
 103             (label ,l3) (label ,l4) (const #f) (call return 1))
 104    (eq? l1 l3) (eq? l2 l4))
 105
 106   (assert-tree-il->glil/pmatch
 107    (apply (primitive null?) (if (const #t) (const 1) (const 2)))
 108    (program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
 109             (const 1) (branch br ,l2)
 110                     (label ,l3) (const 2) (label ,l4)
 111                     (call null? 1) (call return 1))
 112    (eq? l1 l3) (eq? l2 l4)))
 113
 114 (with-test-prefix "primitive-ref"
 115   (assert-tree-il->glil
 116    (primitive +)
 117    (program 0 0 0 0 () (toplevel ref +) (call return 1)))
 118
 119   (assert-tree-il->glil
 120    (begin (primitive +) (const #f))
 121    (program 0 0 0 0 () (const #f) (call return 1)))
 122
 123   (assert-tree-il->glil
 124    (apply (primitive null?) (primitive +))
 125    (program 0 0 0 0 () (toplevel ref +) (call null? 1)
 126             (call return 1))))
 127
 128 (with-test-prefix "lexical refs"
 129   (assert-tree-il->glil
 130    (let (x) (y) ((const 1)) (lexical x y))
 131    (program 0 0 1 0 ()
 132             (const 1) (bind (x local 0)) (local set 0)
 133             (local ref 0) (call return 1)
 134             (unbind)))
 135
 136   (assert-tree-il->glil
 137    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
 138    (program 0 0 1 0 ()
 139             (const 1) (bind (x local 0)) (local set 0)
 140             (const #f) (call return 1)
 141             (unbind)))
 142
 143   (assert-tree-il->glil
 144    (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
 145    (program 0 0 1 0 ()
 146             (const 1) (bind (x local 0)) (local set 0)
 147             (local ref 0) (call null? 1) (call return 1)
 148             (unbind))))
 149
 150 (with-test-prefix "lexical sets"
 151   (assert-tree-il->glil
 152    (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
 153    (program 0 0 0 1 ()
 154             (const 1) (bind (x external 0)) (external set 0 0)
 155             (const 2) (external set 0 0) (void) (call return 1)
 156             (unbind)))
 157
 158   (assert-tree-il->glil
 159    (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
 160    (program 0 0 0 1 ()
 161             (const 1) (bind (x external 0)) (external set 0 0)
 162             (const 2) (external set 0 0) (const #f) (call return 1)
 163             (unbind)))
 164
 165   (assert-tree-il->glil
 166    (let (x) (y) ((const 1))
 167      (apply (primitive null?) (set! (lexical x y) (const 2))))
 168    (program 0 0 0 1 ()
 169             (const 1) (bind (x external 0)) (external set 0 0)
 170             (const 2) (external set 0 0) (void) (call null? 1) (call return 1)
 171             (unbind))))
 172
 173 (with-test-prefix "module refs"
 174   (assert-tree-il->glil
 175    (@ (foo) bar)
 176    (program 0 0 0 0 ()
 177             (module public ref (foo) bar)
 178             (call return 1)))
 179
 180   (assert-tree-il->glil
 181    (begin (@ (foo) bar) (const #f))
 182    (program 0 0 0 0 ()
 183             (module public ref (foo) bar) (call drop 1)
 184             (const #f) (call return 1)))
 185
 186   (assert-tree-il->glil
 187    (apply (primitive null?) (@ (foo) bar))
 188    (program 0 0 0 0 ()
 189             (module public ref (foo) bar)
 190             (call null? 1) (call return 1)))
 191
 192   (assert-tree-il->glil
 193    (@@ (foo) bar)
 194    (program 0 0 0 0 ()
 195             (module private ref (foo) bar)
 196             (call return 1)))
 197
 198   (assert-tree-il->glil
 199    (begin (@@ (foo) bar) (const #f))
 200    (program 0 0 0 0 ()
 201             (module private ref (foo) bar) (call drop 1)
 202             (const #f) (call return 1)))
 203
 204   (assert-tree-il->glil
 205    (apply (primitive null?) (@@ (foo) bar))
 206    (program 0 0 0 0 ()
 207             (module private ref (foo) bar)
 208             (call null? 1) (call return 1))))
 209
 210 (with-test-prefix "module sets"
 211   (assert-tree-il->glil
 212    (set! (@ (foo) bar) (const 2))
 213    (program 0 0 0 0 ()
 214             (const 2) (module public set (foo) bar)
 215             (void) (call return 1)))
 216
 217   (assert-tree-il->glil
 218    (begin (set! (@ (foo) bar) (const 2)) (const #f))
 219    (program 0 0 0 0 ()
 220             (const 2) (module public set (foo) bar)
 221             (const #f) (call return 1)))
 222
 223   (assert-tree-il->glil
 224    (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
 225    (program 0 0 0 0 ()
 226             (const 2) (module public set (foo) bar)
 227             (void) (call null? 1) (call return 1)))
 228
 229   (assert-tree-il->glil
 230    (set! (@@ (foo) bar) (const 2))
 231    (program 0 0 0 0 ()
 232             (const 2) (module private set (foo) bar)
 233             (void) (call return 1)))
 234
 235   (assert-tree-il->glil
 236    (begin (set! (@@ (foo) bar) (const 2)) (const #f))
 237    (program 0 0 0 0 ()
 238             (const 2) (module private set (foo) bar)
 239             (const #f) (call return 1)))
 240
 241   (assert-tree-il->glil
 242    (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
 243    (program 0 0 0 0 ()
 244             (const 2) (module private set (foo) bar)
 245             (void) (call null? 1) (call return 1))))
 246
 247 (with-test-prefix "toplevel refs"
 248   (assert-tree-il->glil
 249    (toplevel bar)
 250    (program 0 0 0 0 ()
 251             (toplevel ref bar)
 252             (call return 1)))
 253
 254   (assert-tree-il->glil
 255    (begin (toplevel bar) (const #f))
 256    (program 0 0 0 0 ()
 257             (toplevel ref bar) (call drop 1)
 258             (const #f) (call return 1)))
 259
 260   (assert-tree-il->glil
 261    (apply (primitive null?) (toplevel bar))
 262    (program 0 0 0 0 ()
 263             (toplevel ref bar)
 264             (call null? 1) (call return 1))))
 265
 266 (with-test-prefix "toplevel sets"
 267   (assert-tree-il->glil
 268    (set! (toplevel bar) (const 2))
 269    (program 0 0 0 0 ()
 270             (const 2) (toplevel set bar)
 271             (void) (call return 1)))
 272
 273   (assert-tree-il->glil
 274    (begin (set! (toplevel bar) (const 2)) (const #f))
 275    (program 0 0 0 0 ()
 276             (const 2) (toplevel set bar)
 277             (const #f) (call return 1)))
 278
 279   (assert-tree-il->glil
 280    (apply (primitive null?) (set! (toplevel bar) (const 2)))
 281    (program 0 0 0 0 ()
 282             (const 2) (toplevel set bar)
 283             (void) (call null? 1) (call return 1))))
 284
 285 (with-test-prefix "toplevel defines"
 286   (assert-tree-il->glil
 287    (define bar (const 2))
 288    (program 0 0 0 0 ()
 289             (const 2) (toplevel define bar)
 290             (void) (call return 1)))
 291
 292   (assert-tree-il->glil
 293    (begin (define bar (const 2)) (const #f))
 294    (program 0 0 0 0 ()
 295             (const 2) (toplevel define bar)
 296             (const #f) (call return 1)))
 297
 298   (assert-tree-il->glil
 299    (apply (primitive null?) (define bar (const 2)))
 300    (program 0 0 0 0 ()
 301             (const 2) (toplevel define bar)
 302             (void) (call null? 1) (call return 1))))
 303
 304 (with-test-prefix "constants"
 305   (assert-tree-il->glil
 306    (const 2)
 307    (program 0 0 0 0 ()
 308             (const 2) (call return 1)))
 309
 310   (assert-tree-il->glil
 311    (begin (const 2) (const #f))
 312    (program 0 0 0 0 ()
 313             (const #f) (call return 1)))
 314
 315   (assert-tree-il->glil
 316    (apply (primitive null?) (const 2))
 317    (program 0 0 0 0 ()
 318             (const 2) (call null? 1) (call return 1))))
 319
 320 (with-test-prefix "lambda"
 321   (assert-tree-il->glil
 322    (lambda (x) (y) () (const 2))
 323    (program 0 0 0 0 ()
 324             (program 1 0 0 0 ()
 325                      (bind (x local 0))
 326                      (const 2) (call return 1))
 327             (call return 1)))
 328
 329   (assert-tree-il->glil
 330    (lambda (x x1) (y y1) () (const 2))
 331    (program 0 0 0 0 ()
 332             (program 2 0 0 0 ()
 333                      (bind (x local 0) (x1 local 1))
 334                      (const 2) (call return 1))
 335             (call return 1)))
 336
 337   (assert-tree-il->glil
 338    (lambda x y () (const 2))
 339    (program 0 0 0 0 ()
 340             (program 1 1 0 0 ()
 341                      (bind (x local 0))
 342                      (const 2) (call return 1))
 343             (call return 1)))
 344
 345   (assert-tree-il->glil
 346    (lambda (x . x1) (y . y1) () (const 2))
 347    (program 0 0 0 0 ()
 348             (program 2 1 0 0 ()
 349                      (bind (x local 0) (x1 local 1))
 350                      (const 2) (call return 1))
 351             (call return 1)))
 352
 353   (assert-tree-il->glil
 354    (lambda (x . x1) (y . y1) () (lexical x y))
 355    (program 0 0 0 0 ()
 356             (program 2 1 0 0 ()
 357                      (bind (x local 0) (x1 local 1))
 358                      (local ref 0) (call return 1))
 359             (call return 1)))
 360
 361   (assert-tree-il->glil
 362    (lambda (x . x1) (y . y1) () (lexical x1 y1))
 363    (program 0 0 0 0 ()
 364             (program 2 1 0 0 ()
 365                      (bind (x local 0) (x1 local 1))
 366                      (local ref 1) (call return 1))
 367             (call return 1)))
 368
 369   (assert-tree-il->glil
 370    (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
 371    (program 0 0 0 0 ()
 372             (program 1 0 0 1 ()
 373                      (bind (x external 0))
 374                      (local ref 0) (external set 0 0)
 375                      (program 1 0 0 0 ()
 376                               (bind (y local 0))
 377                               (external ref 1 0) (call return 1))
 378                      (call return 1))
 379             (call return 1))))
 380
 381 (with-test-prefix "sequence"
 382   (assert-tree-il->glil
 383    (begin (begin (const 2) (const #f)) (const #t))
 384    (program 0 0 0 0 ()
 385             (const #t) (call return 1)))
 386
 387   (assert-tree-il->glil
 388    (apply (primitive null?) (begin (const #f) (const 2)))
 389    (program 0 0 0 0 ()
 390             (const 2) (call null? 1) (call return 1))))
 391
 392 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 393 ;; and could be tightened in any case
 394 (with-test-prefix "the or hack"
 395   (assert-tree-il->glil/pmatch
 396    (let (x) (y) ((const 1))
 397         (if (lexical x y)
 398             (lexical x y)
 399             (let (a) (b) ((const 2))
 400                  (lexical a b))))
 401    (program 0 0 1 0 ()
 402             (const 1) (bind (x local 0)) (local set 0)
 403             (local ref 0) (branch br-if-not ,l1)
 404             (local ref 0) (call return 1)
 405             (label ,l2)
 406             (const 2) (bind (a local 0)) (local set 0)
 407             (local ref 0) (call return 1)
 408             (unbind)
 409             (unbind))
 410    (eq? l1 l2))
 411
 412   (assert-tree-il->glil/pmatch
 413    (let (x) (y) ((const 1))
 414         (if (lexical x y)
 415             (lexical x y)
 416             (let (a) (b) ((const 2))
 417                  (lexical x y))))
 418    (program 0 0 2 0 ()
 419             (const 1) (bind (x local 0)) (local set 0)
 420             (local ref 0) (branch br-if-not ,l1)
 421             (local ref 0) (call return 1)
 422             (label ,l2)
 423             (const 2) (bind (a local 1)) (local set 1)
 424             (local ref 0) (call return 1)
 425             (unbind)
 426             (unbind))
 427    (eq? l1 l2)))
 428
 429 (with-test-prefix "apply"
 430   (assert-tree-il->glil
 431    (apply (primitive @apply) (toplevel foo) (toplevel bar))
 432    (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
 433   (assert-tree-il->glil/pmatch
 434    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
 435    (program 0 0 0 0 ()
 436             (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
 437             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
 438             (label ,l4)
 439             (void) (call return 1))
 440    (and (eq? l1 l3) (eq? l2 l4)))
 441   (assert-tree-il->glil
 442    (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
 443    (program 0 0 0 0 ()
 444             (toplevel ref foo)
 445             (toplevel ref bar) (toplevel ref baz) (call apply 2)
 446             (call goto/args 1))))
 447
 448 (with-test-prefix "call/cc"
 449   (assert-tree-il->glil
 450    (apply (primitive @call-with-current-continuation) (toplevel foo))
 451    (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
 452   (assert-tree-il->glil/pmatch
 453    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
 454    (program 0 0 0 0 ()
 455             (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
 456             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
 457             (label ,l4)
 458             (void) (call return 1))
 459    (and (eq? l1 l3) (eq? l2 l4)))
 460   (assert-tree-il->glil
 461    (apply (toplevel foo)
 462           (apply (toplevel @call-with-current-continuation) (toplevel bar)))
 463    (program 0 0 0 0 ()
 464             (toplevel ref foo)
 465             (toplevel ref bar) (call call/cc 1)
 466             (call goto/args 1))))
 467