test-suite/tests/rtl.test

   1 ;;;; Low-level tests of the RTL assembler -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (tests rtl)
  20   #:use-module (test-suite lib)
  21   #:use-module (system vm assembler)
  22   #:use-module (system vm program)
  23   #:use-module (system vm debug))
  24
  25 (define-syntax-rule (assert-equal val expr)
  26   (let ((x val))
  27     (pass-if (object->string x) (equal? expr x))))
  28
  29 (define (return-constant val)
  30   (assemble-program `((begin-program foo
  31                                      ((name . foo)))
  32                       (assert-nargs-ee/locals 0 1)
  33                       (load-constant 0 ,val)
  34                       (return 0)
  35                       (end-program))))
  36
  37 (define-syntax-rule (assert-constants val ...)
  38   (begin
  39     (assert-equal val ((return-constant val)))
  40     ...))
  41
  42 (with-test-prefix "load-constant"
  43   (assert-constants
  44    1
  45    -1
  46    0
  47    most-positive-fixnum
  48    most-negative-fixnum
  49    #t
  50    #\c
  51    (integer->char 16000)
  52    3.14
  53    "foo"
  54    'foo
  55    #:foo
  56    "æ" ;; a non-ASCII Latin-1 string
  57    "λ" ;; non-ascii, non-latin-1
  58    '(1 . 2)
  59    '(1 2 3 4)
  60    #(1 2 3)
  61    #("foo" "bar" 'baz)
  62    ;; FIXME: Add tests for arrays (uniform and otherwise)
  63    ))
  64
  65 (with-test-prefix "static procedure"
  66   (assert-equal 42
  67                 (((assemble-program `((begin-program foo
  68                                                      ((name . foo)))
  69                                       (assert-nargs-ee/locals 0 1)
  70                                       (load-static-procedure 0 bar)
  71                                       (return 0)
  72                                       (end-program)
  73                                       (begin-program bar
  74                                                      ((name . bar)))
  75                                       (assert-nargs-ee/locals 0 1)
  76                                       (load-constant 0 42)
  77                                       (return 0)
  78                                       (end-program)))))))
  79
  80 (with-test-prefix "loop"
  81   (assert-equal (* 999 500)
  82                 (let ((sumto
  83                        (assemble-program
  84                         ;; 0: limit
  85                         ;; 1: n
  86                         ;; 2: accum
  87                         '((begin-program countdown
  88                                          ((name . countdown)))
  89                           (assert-nargs-ee/locals 1 2)
  90                           (br fix-body)
  91                           (label loop-head)
  92                           (br-if-= 1 0 out)
  93                           (add 2 1 2)
  94                           (add1 1 1)
  95                           (br loop-head)
  96                           (label fix-body)
  97                           (load-constant 1 0)
  98                           (load-constant 2 0)
  99                           (br loop-head)
 100                           (label out)
 101                           (return 2)
 102                           (end-program)))))
 103                   (sumto 1000))))
 104
 105 (with-test-prefix "accum"
 106   (assert-equal (+ 1 2 3)
 107                 (let ((make-accum
 108                        (assemble-program
 109                         ;; 0: elt
 110                         ;; 1: tail
 111                         ;; 2: head
 112                         '((begin-program make-accum
 113                                          ((name . make-accum)))
 114                           (assert-nargs-ee/locals 0 2)
 115                           (load-constant 0 0)
 116                           (box 0 0)
 117                           (make-closure 1 accum (0))
 118                           (return 1)
 119                           (end-program)
 120                           (begin-program accum
 121                                          ((name . accum)))
 122                           (assert-nargs-ee/locals 1 2)
 123                           (free-ref 1 0)
 124                           (box-ref 2 1)
 125                           (add 2 2 0)
 126                           (box-set! 1 2)
 127                           (return 2)
 128                           (end-program)))))
 129                   (let ((accum (make-accum)))
 130                     (accum 1)
 131                     (accum 2)
 132                     (accum 3)))))
 133
 134 (with-test-prefix "call"
 135   (assert-equal 42
 136                 (let ((call ;; (lambda (x) (x))
 137                        (assemble-program
 138                         '((begin-program call
 139                                          ((name . call)))
 140                           (assert-nargs-ee/locals 1 0)
 141                           (call 1 0 ())
 142                           (return 1) ;; MVRA from call
 143                           (return 1) ;; RA from call
 144                           (end-program)))))
 145                   (call (lambda () 42))))
 146
 147   (assert-equal 6
 148                 (let ((call-with-3 ;; (lambda (x) (x 3))
 149                        (assemble-program
 150                         '((begin-program call-with-3
 151                                          ((name . call-with-3)))
 152                           (assert-nargs-ee/locals 1 1)
 153                           (load-constant 1 3)
 154                           (call 2 0 (1))
 155                           (return 2) ;; MVRA from call
 156                           (return 2) ;; RA from call
 157                           (end-program)))))
 158                   (call-with-3 (lambda (x) (* x 2))))))
 159
 160 (with-test-prefix "tail-call"
 161   (assert-equal 3
 162                 (let ((call ;; (lambda (x) (x))
 163                        (assemble-program
 164                         '((begin-program call
 165                                          ((name . call)))
 166                           (assert-nargs-ee/locals 1 0)
 167                           (tail-call 0 0)
 168                           (end-program)))))
 169                   (call (lambda () 3))))
 170
 171   (assert-equal 6
 172                 (let ((call-with-3 ;; (lambda (x) (x 3))
 173                        (assemble-program
 174                         '((begin-program call-with-3
 175                                          ((name . call-with-3)))
 176                           (assert-nargs-ee/locals 1 1)
 177                           (mov 1 0) ;; R1 <- R0
 178                           (load-constant 0 3) ;; R0 <- 3
 179                           (tail-call 1 1)
 180                           (end-program)))))
 181                   (call-with-3 (lambda (x) (* x 2))))))
 182
 183 (with-test-prefix "cached-toplevel-ref"
 184   (assert-equal 5.0
 185                 (let ((get-sqrt-trampoline
 186                        (assemble-program
 187                         '((begin-program get-sqrt-trampoline
 188                                          ((name . get-sqrt-trampoline)))
 189                           (assert-nargs-ee/locals 0 1)
 190                           (cache-current-module! 0 sqrt-scope)
 191                           (load-static-procedure 0 sqrt-trampoline)
 192                           (return 0)
 193                           (end-program)
 194
 195                           (begin-program sqrt-trampoline
 196                                          ((name . sqrt-trampoline)))
 197                           (assert-nargs-ee/locals 1 1)
 198                           (cached-toplevel-ref 1 sqrt-scope sqrt)
 199                           (tail-call 1 1)
 200                           (end-program)))))
 201                   ((get-sqrt-trampoline) 25.0))))
 202
 203 (define *top-val* 0)
 204
 205 (with-test-prefix "cached-toplevel-set!"
 206   (let ((prev *top-val*))
 207     (assert-equal (1+ prev)
 208                   (let ((make-top-incrementor
 209                          (assemble-program
 210                           '((begin-program make-top-incrementor
 211                                            ((name . make-top-incrementor)))
 212                             (assert-nargs-ee/locals 0 1)
 213                             (cache-current-module! 0 top-incrementor)
 214                             (load-static-procedure 0 top-incrementor)
 215                             (return 0)
 216                             (end-program)
 217
 218                             (begin-program top-incrementor
 219                                            ((name . top-incrementor)))
 220                             (assert-nargs-ee/locals 0 1)
 221                             (cached-toplevel-ref 0 top-incrementor *top-val*)
 222                             (add1 0 0)
 223                             (cached-toplevel-set! 0 top-incrementor *top-val*)
 224                             (return/values 0)
 225                             (end-program)))))
 226                     ((make-top-incrementor))
 227                     *top-val*))))
 228
 229 (with-test-prefix "cached-module-ref"
 230   (assert-equal 5.0
 231                 (let ((get-sqrt-trampoline
 232                        (assemble-program
 233                         '((begin-program get-sqrt-trampoline
 234                                          ((name . get-sqrt-trampoline)))
 235                           (assert-nargs-ee/locals 0 1)
 236                           (load-static-procedure 0 sqrt-trampoline)
 237                           (return 0)
 238                           (end-program)
 239
 240                           (begin-program sqrt-trampoline
 241                                          ((name . sqrt-trampoline)))
 242                           (assert-nargs-ee/locals 1 1)
 243                           (cached-module-ref 1 (guile) #t sqrt)
 244                           (tail-call 1 1)
 245                           (end-program)))))
 246                   ((get-sqrt-trampoline) 25.0))))
 247
 248 (with-test-prefix "cached-module-set!"
 249   (let ((prev *top-val*))
 250     (assert-equal (1+ prev)
 251                   (let ((make-top-incrementor
 252                          (assemble-program
 253                           '((begin-program make-top-incrementor
 254                                            ((name . make-top-incrementor)))
 255                             (assert-nargs-ee/locals 0 1)
 256                             (load-static-procedure 0 top-incrementor)
 257                             (return 0)
 258                             (end-program)
 259
 260                             (begin-program top-incrementor
 261                                            ((name . top-incrementor)))
 262                             (assert-nargs-ee/locals 0 1)
 263                             (cached-module-ref 0 (tests rtl) #f *top-val*)
 264                             (add1 0 0)
 265                             (cached-module-set! 0 (tests rtl) #f *top-val*)
 266                             (return 0)
 267                             (end-program)))))
 268                     ((make-top-incrementor))
 269                     *top-val*))))
 270
 271 (with-test-prefix "debug contexts"
 272   (let ((return-3 (assemble-program
 273                    '((begin-program return-3 ((name . return-3)))
 274                      (assert-nargs-ee/locals 0 1)
 275                      (load-constant 0 3)
 276                      (return 0)
 277                      (end-program)))))
 278     (pass-if "program name"
 279       (and=> (find-program-debug-info (rtl-program-code return-3))
 280              (lambda (pdi)
 281                (equal? (program-debug-info-name pdi)
 282                        'return-3))))
 283
 284     (pass-if "program address"
 285       (and=> (find-program-debug-info (rtl-program-code return-3))
 286              (lambda (pdi)
 287                (equal? (program-debug-info-addr pdi)
 288                        (rtl-program-code return-3)))))))
 289
 290 (with-test-prefix "procedure name"
 291   (pass-if-equal 'foo
 292       (procedure-name
 293        (assemble-program
 294         '((begin-program foo ((name . foo)))
 295           (assert-nargs-ee/locals 0 1)
 296           (load-constant 0 42)
 297           (return 0)
 298           (end-program))))))