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 () 1 #f)
  33                       (load-constant 0 ,val)
  34                       (return 0)
  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 () 1 #f)
  71                                       (load-static-procedure 0 bar)
  72                                       (return 0)
  73                                       (end-arity)
  74                                       (end-program)
  75                                       (begin-program bar
  76                                                      ((name . bar)))
  77                                       (begin-standard-arity () 1 #f)
  78                                       (load-constant 0 42)
  79                                       (return 0)
  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) 3 #f)
  93                           (br fix-body)
  94                           (label loop-head)
  95                           (br-if-= 1 0 out)
  96                           (add 2 1 2)
  97                           (add1 1 1)
  98                           (br loop-head)
  99                           (label fix-body)
 100                           (load-constant 1 0)
 101                           (load-constant 2 0)
 102                           (br loop-head)
 103                           (label out)
 104                           (return 2)
 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 () 2 #f)
 119                           (load-constant 0 0)
 120                           (box 0 0)
 121                           (make-closure 1 accum (0))
 122                           (return 1)
 123                           (end-arity)
 124                           (end-program)
 125                           (begin-program accum
 126                                          ((name . accum)))
 127                           (begin-standard-arity (x) 3 #f)
 128                           (free-ref 1 0)
 129                           (box-ref 2 1)
 130                           (add 2 2 0)
 131                           (box-set! 1 2)
 132                           (return 2)
 133                           (end-arity)
 134                           (end-program)))))
 135                   (let ((accum (make-accum)))
 136                     (accum 1)
 137                     (accum 2)
 138                     (accum 3)))))
 139
 140 (with-test-prefix "call"
 141   (assert-equal 42
 142                 (let ((call ;; (lambda (x) (x))
 143                        (assemble-program
 144                         '((begin-program call
 145                                          ((name . call)))
 146                           (begin-standard-arity (f) 1 #f)
 147                           (call 1 0 ())
 148                           (return 1) ;; MVRA from call
 149                           (return 1) ;; RA from call
 150                           (end-arity)
 151                           (end-program)))))
 152                   (call (lambda () 42))))
 153
 154   (assert-equal 6
 155                 (let ((call-with-3 ;; (lambda (x) (x 3))
 156                        (assemble-program
 157                         '((begin-program call-with-3
 158                                          ((name . call-with-3)))
 159                           (begin-standard-arity (f) 2 #f)
 160                           (load-constant 1 3)
 161                           (call 2 0 (1))
 162                           (return 2) ;; MVRA from call
 163                           (return 2) ;; RA from call
 164                           (end-arity)
 165                           (end-program)))))
 166                   (call-with-3 (lambda (x) (* x 2))))))
 167
 168 (with-test-prefix "tail-call"
 169   (assert-equal 3
 170                 (let ((call ;; (lambda (x) (x))
 171                        (assemble-program
 172                         '((begin-program call
 173                                          ((name . call)))
 174                           (begin-standard-arity (f) 1 #f)
 175                           (tail-call 0 0)
 176                           (end-arity)
 177                           (end-program)))))
 178                   (call (lambda () 3))))
 179
 180   (assert-equal 6
 181                 (let ((call-with-3 ;; (lambda (x) (x 3))
 182                        (assemble-program
 183                         '((begin-program call-with-3
 184                                          ((name . call-with-3)))
 185                           (begin-standard-arity (f) 2 #f)
 186                           (mov 1 0) ;; R1 <- R0
 187                           (load-constant 0 3) ;; R0 <- 3
 188                           (tail-call 1 1)
 189                           (end-arity)
 190                           (end-program)))))
 191                   (call-with-3 (lambda (x) (* x 2))))))
 192
 193 (with-test-prefix "cached-toplevel-ref"
 194   (assert-equal 5.0
 195                 (let ((get-sqrt-trampoline
 196                        (assemble-program
 197                         '((begin-program get-sqrt-trampoline
 198                                          ((name . get-sqrt-trampoline)))
 199                           (begin-standard-arity () 1 #f)
 200                           (cache-current-module! 0 sqrt-scope)
 201                           (load-static-procedure 0 sqrt-trampoline)
 202                           (return 0)
 203                           (end-arity)
 204                           (end-program)
 205
 206                           (begin-program sqrt-trampoline
 207                                          ((name . sqrt-trampoline)))
 208                           (begin-standard-arity (x) 2 #f)
 209                           (cached-toplevel-ref 1 sqrt-scope sqrt)
 210                           (tail-call 1 1)
 211                           (end-arity)
 212                           (end-program)))))
 213                   ((get-sqrt-trampoline) 25.0))))
 214
 215 (define *top-val* 0)
 216
 217 (with-test-prefix "cached-toplevel-set!"
 218   (let ((prev *top-val*))
 219     (assert-equal (1+ prev)
 220                   (let ((make-top-incrementor
 221                          (assemble-program
 222                           '((begin-program make-top-incrementor
 223                                            ((name . make-top-incrementor)))
 224                             (begin-standard-arity () 1 #f)
 225                             (cache-current-module! 0 top-incrementor)
 226                             (load-static-procedure 0 top-incrementor)
 227                             (return 0)
 228                             (end-arity)
 229                             (end-program)
 230
 231                             (begin-program top-incrementor
 232                                            ((name . top-incrementor)))
 233                             (begin-standard-arity () 1 #f)
 234                             (cached-toplevel-ref 0 top-incrementor *top-val*)
 235                             (add1 0 0)
 236                             (cached-toplevel-set! 0 top-incrementor *top-val*)
 237                             (return/values 0)
 238                             (end-arity)
 239                             (end-program)))))
 240                     ((make-top-incrementor))
 241                     *top-val*))))
 242
 243 (with-test-prefix "cached-module-ref"
 244   (assert-equal 5.0
 245                 (let ((get-sqrt-trampoline
 246                        (assemble-program
 247                         '((begin-program get-sqrt-trampoline
 248                                          ((name . get-sqrt-trampoline)))
 249                           (begin-standard-arity () 1 #f)
 250                           (load-static-procedure 0 sqrt-trampoline)
 251                           (return 0)
 252                           (end-arity)
 253                           (end-program)
 254
 255                           (begin-program sqrt-trampoline
 256                                          ((name . sqrt-trampoline)))
 257                           (begin-standard-arity (x) 2 #f)
 258                           (cached-module-ref 1 (guile) #t sqrt)
 259                           (tail-call 1 1)
 260                           (end-arity)
 261                           (end-program)))))
 262                   ((get-sqrt-trampoline) 25.0))))
 263
 264 (with-test-prefix "cached-module-set!"
 265   (let ((prev *top-val*))
 266     (assert-equal (1+ prev)
 267                   (let ((make-top-incrementor
 268                          (assemble-program
 269                           '((begin-program make-top-incrementor
 270                                            ((name . make-top-incrementor)))
 271                             (begin-standard-arity () 1 #f)
 272                             (load-static-procedure 0 top-incrementor)
 273                             (return 0)
 274                             (end-arity)
 275                             (end-program)
 276
 277                             (begin-program top-incrementor
 278                                            ((name . top-incrementor)))
 279                             (begin-standard-arity () 1 #f)
 280                             (cached-module-ref 0 (tests rtl) #f *top-val*)
 281                             (add1 0 0)
 282                             (cached-module-set! 0 (tests rtl) #f *top-val*)
 283                             (return 0)
 284                             (end-arity)
 285                             (end-program)))))
 286                     ((make-top-incrementor))
 287                     *top-val*))))
 288
 289 (with-test-prefix "debug contexts"
 290   (let ((return-3 (assemble-program
 291                    '((begin-program return-3 ((name . return-3)))
 292                      (begin-standard-arity () 1 #f)
 293                      (load-constant 0 3)
 294                      (return 0)
 295                      (end-arity)
 296                      (end-program)))))
 297     (pass-if "program name"
 298       (and=> (find-program-debug-info (rtl-program-code return-3))
 299              (lambda (pdi)
 300                (equal? (program-debug-info-name pdi)
 301                        'return-3))))
 302
 303     (pass-if "program address"
 304       (and=> (find-program-debug-info (rtl-program-code return-3))
 305              (lambda (pdi)
 306                (equal? (program-debug-info-addr pdi)
 307                        (rtl-program-code return-3)))))))
 308
 309 (with-test-prefix "procedure name"
 310   (pass-if-equal 'foo
 311       (procedure-name
 312        (assemble-program
 313         '((begin-program foo ((name . foo)))
 314           (begin-standard-arity () 1 #f)
 315           (load-constant 0 42)
 316           (return 0)
 317           (end-arity)
 318           (end-program))))))
 319
 320 (with-test-prefix "simply procedure arity"
 321   (pass-if-equal "#<procedure foo ()>"
 322       (object->string
 323        (assemble-program
 324         '((begin-program foo ((name . foo)))
 325           (begin-standard-arity () 1 #f)
 326           (load-constant 0 42)
 327           (return 0)
 328           (end-arity)
 329           (end-program)))))
 330   (pass-if-equal "#<procedure foo (x y)>"
 331       (object->string
 332        (assemble-program
 333         '((begin-program foo ((name . foo)))
 334           (begin-standard-arity (x y) 2 #f)
 335           (load-constant 0 42)
 336           (return 0)
 337           (end-arity)
 338           (end-program)))))
 339
 340   (pass-if-equal "#<procedure foo (x #:optional y . z)>"
 341       (object->string
 342        (assemble-program
 343         '((begin-program foo ((name . foo)))
 344           (begin-opt-arity (x) (y) z 3 #f)
 345           (load-constant 0 42)
 346           (return 0)
 347           (end-arity)
 348           (end-program))))))
 349
 350 (with-test-prefix "procedure docstrings"
 351   (pass-if-equal "qux qux"
 352       (procedure-documentation
 353        (assemble-program
 354         '((begin-program foo ((name . foo) (documentation . "qux qux")))
 355           (begin-standard-arity () 1 #f)
 356           (load-constant 0 42)
 357           (return 0)
 358           (end-arity)
 359           (end-program))))))
 360
 361 (with-test-prefix "procedure properties"
 362   ;; No properties.
 363   (pass-if-equal '()
 364       (procedure-properties
 365        (assemble-program
 366         '((begin-program foo ())
 367           (begin-standard-arity () 1 #f)
 368           (load-constant 0 42)
 369           (return 0)
 370           (end-arity)
 371           (end-program)))))
 372
 373   ;; Name and docstring (which actually don't go out to procprops).
 374   (pass-if-equal '((name . foo)
 375                    (documentation . "qux qux"))
 376       (procedure-properties
 377        (assemble-program
 378         '((begin-program foo ((name . foo) (documentation . "qux qux")))
 379           (begin-standard-arity () 1 #f)
 380           (load-constant 0 42)
 381           (return 0)
 382           (end-arity)
 383           (end-program)))))
 384
 385   ;; A property that actually needs serialization.
 386   (pass-if-equal '((name . foo)
 387                    (documentation . "qux qux")
 388                    (moo . "mooooooooooooo"))
 389       (procedure-properties
 390        (assemble-program
 391         '((begin-program foo ((name . foo)
 392                               (documentation . "qux qux")
 393                               (moo . "mooooooooooooo")))
 394           (begin-standard-arity () 1 #f)
 395           (load-constant 0 42)
 396           (return 0)
 397           (end-arity)
 398           (end-program)))))
 399
 400   ;; Procedure-name still works in this case.
 401   (pass-if-equal 'foo
 402       (procedure-name
 403        (assemble-program
 404         '((begin-program foo ((name . foo)
 405                               (documentation . "qux qux")
 406                               (moo . "mooooooooooooo")))
 407           (begin-standard-arity () 1 #f)
 408           (load-constant 0 42)
 409           (return 0)
 410           (end-arity)
 411           (end-program))))))