test-suite/tests/rtl.test

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