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                       (begin-standard-arity () 2 #f)
  33                       (load-constant 1 ,val)
  34                       (return 1)
  35                       (end-arity)
  36                       (end-program))))
  37
  38 (define-syntax-rule (assert-constants val ...)
  39   (begin
  40     (assert-equal val ((return-constant val)))
  41     ...))
  42
  43 (with-test-prefix "load-constant"
  44   (assert-constants
  45    1
  46    -1
  47    0
  48    most-positive-fixnum
  49    most-negative-fixnum
  50    #t
  51    #\c
  52    (integer->char 16000)
  53    3.14
  54    "foo"
  55    'foo
  56    #:foo
  57    "æ" ;; a non-ASCII Latin-1 string
  58    "λ" ;; non-ascii, non-latin-1
  59    '(1 . 2)
  60    '(1 2 3 4)
  61    #(1 2 3)
  62    #("foo" "bar" 'baz)
  63    ;; FIXME: Add tests for arrays (uniform and otherwise)
  64    ))
  65
  66 (with-test-prefix "static procedure"
  67   (assert-equal 42
  68                 (((assemble-program `((begin-program foo
  69                                                      ((name . foo)))
  70                                       (begin-standard-arity () 2 #f)
  71                                       (load-static-procedure 1 bar)
  72                                       (return 1)
  73                                       (end-arity)
  74                                       (end-program)
  75                                       (begin-program bar
  76                                                      ((name . bar)))
  77                                       (begin-standard-arity () 2 #f)
  78                                       (load-constant 1 42)
  79                                       (return 1)
  80                                       (end-arity)
  81                                       (end-program)))))))
  82
  83 (with-test-prefix "loop"
  84   (assert-equal (* 999 500)
  85                 (let ((sumto
  86                        (assemble-program
  87                         ;; 0: limit
  88                         ;; 1: n
  89                         ;; 2: accum
  90                         '((begin-program countdown
  91                                          ((name . countdown)))
  92                           (begin-standard-arity (x) 4 #f)
  93                           (br fix-body)
  94                           (label loop-head)
  95                           (br-if-= 2 1 #f out)
  96                           (add 3 2 3)
  97                           (add1 2 2)
  98                           (br loop-head)
  99                           (label fix-body)
 100                           (load-constant 2 0)
 101                           (load-constant 3 0)
 102                           (br loop-head)
 103                           (label out)
 104                           (return 3)
 105                           (end-arity)
 106                           (end-program)))))
 107                   (sumto 1000))))
 108
 109 (with-test-prefix "accum"
 110   (assert-equal (+ 1 2 3)
 111                 (let ((make-accum
 112                        (assemble-program
 113                         ;; 0: elt
 114                         ;; 1: tail
 115                         ;; 2: head
 116                         '((begin-program make-accum
 117                                          ((name . make-accum)))
 118                           (begin-standard-arity () 3 #f)
 119                           (load-constant 1 0)
 120                           (box 1 1)
 121                           (make-closure 2 accum 1)
 122                           (free-set! 2 1 0)
 123                           (return 2)
 124                           (end-arity)
 125                           (end-program)
 126                           (begin-program accum
 127                                          ((name . accum)))
 128                           (begin-standard-arity (x) 4 #f)
 129                           (free-ref 2 0 0)
 130                           (box-ref 3 2)
 131                           (add 3 3 1)
 132                           (box-set! 2 3)
 133                           (return 3)
 134                           (end-arity)
 135                           (end-program)))))
 136                   (let ((accum (make-accum)))
 137                     (accum 1)
 138                     (accum 2)
 139                     (accum 3)))))
 140
 141 (with-test-prefix "call"
 142   (assert-equal 42
 143                 (let ((call ;; (lambda (x) (x))
 144                        (assemble-program
 145                         '((begin-program call
 146                                          ((name . call)))
 147                           (begin-standard-arity (f) 7 #f)
 148                           (mov 5 1)
 149                           (call 5 1)
 150                           (receive 2 5 7)
 151                           (return 2)
 152                           (end-arity)
 153                           (end-program)))))
 154                   (call (lambda () 42))))
 155
 156   (assert-equal 6
 157                 (let ((call-with-3 ;; (lambda (x) (x 3))
 158                        (assemble-program
 159                         '((begin-program call-with-3
 160                                          ((name . call-with-3)))
 161                           (begin-standard-arity (f) 7 #f)
 162                           (mov 5 1)
 163                           (load-constant 6 3)
 164                           (call 5 2)
 165                           (receive 2 5 7)
 166                           (return 2)
 167                           (end-arity)
 168                           (end-program)))))
 169                   (call-with-3 (lambda (x) (* x 2))))))
 170
 171 (with-test-prefix "tail-call"
 172   (assert-equal 3
 173                 (let ((call ;; (lambda (x) (x))
 174                        (assemble-program
 175                         '((begin-program call
 176                                          ((name . call)))
 177                           (begin-standard-arity (f) 2 #f)
 178                           (mov 0 1)
 179                           (tail-call 1)
 180                           (end-arity)
 181                           (end-program)))))
 182                   (call (lambda () 3))))
 183
 184   (assert-equal 6
 185                 (let ((call-with-3 ;; (lambda (x) (x 3))
 186                        (assemble-program
 187                         '((begin-program call-with-3
 188                                          ((name . call-with-3)))
 189                           (begin-standard-arity (f) 2 #f)
 190                           (mov 0 1) ;; R0 <- R1
 191                           (load-constant 1 3) ;; R1 <- 3
 192                           (tail-call 2)
 193                           (end-arity)
 194                           (end-program)))))
 195                   (call-with-3 (lambda (x) (* x 2))))))
 196
 197 (with-test-prefix "cached-toplevel-ref"
 198   (assert-equal 5.0
 199                 (let ((get-sqrt-trampoline
 200                        (assemble-program
 201                         '((begin-program get-sqrt-trampoline
 202                                          ((name . get-sqrt-trampoline)))
 203                           (begin-standard-arity () 2 #f)
 204                           (current-module 1)
 205                           (cache-current-module! 1 sqrt-scope)
 206                           (load-static-procedure 1 sqrt-trampoline)
 207                           (return 1)
 208                           (end-arity)
 209                           (end-program)
 210
 211                           (begin-program sqrt-trampoline
 212                                          ((name . sqrt-trampoline)))
 213                           (begin-standard-arity (x) 3 #f)
 214                           (cached-toplevel-box 2 sqrt-scope sqrt #t)
 215                           (box-ref 0 2)
 216                           (tail-call 2)
 217                           (end-arity)
 218                           (end-program)))))
 219                   ((get-sqrt-trampoline) 25.0))))
 220
 221 (define *top-val* 0)
 222
 223 (with-test-prefix "cached-toplevel-set!"
 224   (let ((prev *top-val*))
 225     (assert-equal (1+ prev)
 226                   (let ((make-top-incrementor
 227                          (assemble-program
 228                           '((begin-program make-top-incrementor
 229                                            ((name . make-top-incrementor)))
 230                             (begin-standard-arity () 2 #f)
 231                             (current-module 1)
 232                             (cache-current-module! 1 top-incrementor)
 233                             (load-static-procedure 1 top-incrementor)
 234                             (return 1)
 235                             (end-arity)
 236                             (end-program)
 237
 238                             (begin-program top-incrementor
 239                                            ((name . top-incrementor)))
 240                             (begin-standard-arity () 3 #f)
 241                             (cached-toplevel-box 1 top-incrementor *top-val* #t)
 242                             (box-ref 2 1)
 243                             (add1 2 2)
 244                             (box-set! 1 2)
 245                             (return-values 0)
 246                             (end-arity)
 247                             (end-program)))))
 248                     ((make-top-incrementor))
 249                     *top-val*))))
 250
 251 (with-test-prefix "cached-module-ref"
 252   (assert-equal 5.0
 253                 (let ((get-sqrt-trampoline
 254                        (assemble-program
 255                         '((begin-program get-sqrt-trampoline
 256                                          ((name . get-sqrt-trampoline)))
 257                           (begin-standard-arity () 2 #f)
 258                           (load-static-procedure 1 sqrt-trampoline)
 259                           (return 1)
 260                           (end-arity)
 261                           (end-program)
 262
 263                           (begin-program sqrt-trampoline
 264                                          ((name . sqrt-trampoline)))
 265                           (begin-standard-arity (x) 3 #f)
 266                           (cached-module-box 2 (guile) sqrt #t #t)
 267                           (box-ref 0 2)
 268                           (tail-call 2)
 269                           (end-arity)
 270                           (end-program)))))
 271                   ((get-sqrt-trampoline) 25.0))))
 272
 273 (with-test-prefix "cached-module-set!"
 274   (let ((prev *top-val*))
 275     (assert-equal (1+ prev)
 276                   (let ((make-top-incrementor
 277                          (assemble-program
 278                           '((begin-program make-top-incrementor
 279                                            ((name . make-top-incrementor)))
 280                             (begin-standard-arity () 2 #f)
 281                             (load-static-procedure 1 top-incrementor)
 282                             (return 1)
 283                             (end-arity)
 284                             (end-program)
 285
 286                             (begin-program top-incrementor
 287                                            ((name . top-incrementor)))
 288                             (begin-standard-arity () 3 #f)
 289                             (cached-module-box 1 (tests rtl) *top-val* #f #t)
 290                             (box-ref 2 1)
 291                             (add1 2 2)
 292                             (box-set! 1 2)
 293                             (return 2)
 294                             (end-arity)
 295                             (end-program)))))
 296                     ((make-top-incrementor))
 297                     *top-val*))))
 298
 299 (with-test-prefix "debug contexts"
 300   (let ((return-3 (assemble-program
 301                    '((begin-program return-3 ((name . return-3)))
 302                      (begin-standard-arity () 2 #f)
 303                      (load-constant 1 3)
 304                      (return 1)
 305                      (end-arity)
 306                      (end-program)))))
 307     (pass-if "program name"
 308       (and=> (find-program-debug-info (rtl-program-code return-3))
 309              (lambda (pdi)
 310                (equal? (program-debug-info-name pdi)
 311                        'return-3))))
 312
 313     (pass-if "program address"
 314       (and=> (find-program-debug-info (rtl-program-code return-3))
 315              (lambda (pdi)
 316                (equal? (program-debug-info-addr pdi)
 317                        (rtl-program-code return-3)))))))
 318
 319 (with-test-prefix "procedure name"
 320   (pass-if-equal 'foo
 321       (procedure-name
 322        (assemble-program
 323         '((begin-program foo ((name . foo)))
 324           (begin-standard-arity () 2 #f)
 325           (load-constant 1 42)
 326           (return 1)
 327           (end-arity)
 328           (end-program))))))
 329
 330 (with-test-prefix "simply procedure arity"
 331   (pass-if-equal "#<procedure foo ()>"
 332       (object->string
 333        (assemble-program
 334         '((begin-program foo ((name . foo)))
 335           (begin-standard-arity () 2 #f)
 336           (load-constant 1 42)
 337           (return 1)
 338           (end-arity)
 339           (end-program)))))
 340   (pass-if-equal "#<procedure foo (x y)>"
 341       (object->string
 342        (assemble-program
 343         '((begin-program foo ((name . foo)))
 344           (begin-standard-arity (x y) 3 #f)
 345           (load-constant 1 42)
 346           (return 1)
 347           (end-arity)
 348           (end-program)))))
 349
 350   (pass-if-equal "#<procedure foo (x #:optional y . z)>"
 351       (object->string
 352        (assemble-program
 353         '((begin-program foo ((name . foo)))
 354           (begin-opt-arity (x) (y) z 4 #f)
 355           (load-constant 1 42)
 356           (return 1)
 357           (end-arity)
 358           (end-program))))))
 359
 360 (with-test-prefix "procedure docstrings"
 361   (pass-if-equal "qux qux"
 362       (procedure-documentation
 363        (assemble-program
 364         '((begin-program foo ((name . foo) (documentation . "qux qux")))
 365           (begin-standard-arity () 2 #f)
 366           (load-constant 1 42)
 367           (return 1)
 368           (end-arity)
 369           (end-program))))))
 370
 371 (with-test-prefix "procedure properties"
 372   ;; No properties.
 373   (pass-if-equal '()
 374       (procedure-properties
 375        (assemble-program
 376         '((begin-program foo ())
 377           (begin-standard-arity () 2 #f)
 378           (load-constant 1 42)
 379           (return 1)
 380           (end-arity)
 381           (end-program)))))
 382
 383   ;; Name and docstring (which actually don't go out to procprops).
 384   (pass-if-equal '((name . foo)
 385                    (documentation . "qux qux"))
 386       (procedure-properties
 387        (assemble-program
 388         '((begin-program foo ((name . foo) (documentation . "qux qux")))
 389           (begin-standard-arity () 2 #f)
 390           (load-constant 1 42)
 391           (return 1)
 392           (end-arity)
 393           (end-program)))))
 394
 395   ;; A property that actually needs serialization.
 396   (pass-if-equal '((name . foo)
 397                    (documentation . "qux qux")
 398                    (moo . "mooooooooooooo"))
 399       (procedure-properties
 400        (assemble-program
 401         '((begin-program foo ((name . foo)
 402                               (documentation . "qux qux")
 403                               (moo . "mooooooooooooo")))
 404           (begin-standard-arity () 2 #f)
 405           (load-constant 1 42)
 406           (return 1)
 407           (end-arity)
 408           (end-program)))))
 409
 410   ;; Procedure-name still works in this case.
 411   (pass-if-equal 'foo
 412       (procedure-name
 413        (assemble-program
 414         '((begin-program foo ((name . foo)
 415                               (documentation . "qux qux")
 416                               (moo . "mooooooooooooo")))
 417           (begin-standard-arity () 2 #f)
 418           (load-constant 1 42)
 419           (return 1)
 420           (end-arity)
 421           (end-program))))))