module/language/glil/compile-assembly.scm

   1 ;;; Guile VM assembler
   2
   3 ;; Copyright (C) 2001, 2009 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 ;;; Code:
  20
  21 (define-module (language glil compile-assembly)
  22   #:use-module (system base syntax)
  23   #:use-module (system base pmatch)
  24   #:use-module (language glil)
  25   #:use-module (language assembly)
  26   #:use-module (system vm instruction)
  27   #:use-module ((system vm program) #:select (make-binding))
  28   #:use-module (ice-9 receive)
  29   #:use-module ((srfi srfi-1) #:select (fold))
  30   #:use-module (rnrs bytevector)
  31   #:export (compile-assembly))
  32
  33 ;; Variable cache cells go in the object table, and serialize as their
  34 ;; keys. The reason we wrap the keys in these records is so they don't
  35 ;; compare as `equal?' to other objects in the object table.
  36 ;;
  37 ;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?)
  38
  39 (define-record <variable-cache-cell> key)
  40
  41 ;; Subprograms can be loaded into an object table as well. We need a
  42 ;; disjoint type here too. (Subprograms have their own object tables --
  43 ;; though probably we should just make one table per compilation unit.)
  44
  45 (define-record <subprogram> table prog)
  46
  47
  48 (define (limn-sources sources)
  49   (let lp ((in sources) (out '()) (filename #f))
  50     (if (null? in)
  51         (reverse! out)
  52         (let ((addr (caar in))
  53               (new-filename (assq-ref (cdar in ) 'filename))
  54               (line (assq-ref (cdar in) 'line))
  55               (column (assq-ref (cdar in) 'column)))
  56           (cond
  57            ((not (equal? new-filename filename))
  58             (lp (cdr in)
  59                 `((,addr . (,line . ,column))
  60                   (filename . ,new-filename)
  61                   . ,out)
  62                 new-filename))
  63            ((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
  64             (lp (cdr in)
  65                 `((,addr . (,line . ,column))
  66                   . ,out)
  67                 filename))
  68            (else
  69             (lp (cdr in) out filename)))))))
  70
  71 (define (make-meta bindings sources arities tail)
  72   (if (and (null? bindings) (null? sources) (null? tail))
  73       #f
  74       (compile-assembly
  75        (make-glil-program '()
  76                           (list
  77                            (make-glil-const `(,bindings ,sources ,arities ,@tail))
  78                            (make-glil-call 'return 1))))))
  79
  80 ;; A functional stack of names of live variables.
  81 (define (make-open-binding name boxed? index)
  82   (list name boxed? index))
  83 (define (make-closed-binding open-binding start end)
  84   (make-binding (car open-binding) (cadr open-binding)
  85                 (caddr open-binding) start end))
  86 (define (open-binding bindings vars start)
  87   (cons
  88    (acons start
  89           (map
  90            (lambda (v)
  91              (pmatch v
  92                ((,name ,boxed? ,i)
  93                 (make-open-binding name boxed? i))
  94                (else (error "unknown binding type" v))))
  95            vars)
  96           (car bindings))
  97    (cdr bindings)))
  98 (define (close-binding bindings end)
  99   (pmatch bindings
 100     ((((,start . ,closing) . ,open) . ,closed)
 101      (cons open
 102            (fold (lambda (o tail)
 103                    ;; the cons is for dsu sort
 104                    (acons start (make-closed-binding o start end)
 105                           tail))
 106                  closed
 107                  closing)))
 108     (else (error "broken bindings" bindings))))
 109 (define (close-all-bindings bindings end)
 110   (if (null? (car bindings))
 111       (map cdr
 112            (stable-sort (reverse (cdr bindings))
 113                         (lambda (x y) (< (car x) (car y)))))
 114       (close-all-bindings (close-binding bindings end) end)))
 115
 116 ;; A functional object table.
 117 (define *module* 1)
 118 (define (assoc-ref-or-acons alist x make-y)
 119   (cond ((assoc-ref alist x)
 120          => (lambda (y) (values y alist)))
 121         (else
 122          (let ((y (make-y x alist)))
 123            (values y (acons x y alist))))))
 124 (define (object-index-and-alist x alist)
 125   (assoc-ref-or-acons alist x
 126                       (lambda (x alist)
 127                         (+ (length alist) *module*))))
 128 (define (make-object-table objects)
 129   (and (not (null? objects))
 130        (list->vector (cons #f objects))))
 131
 132 ;; A functional arities thingamajiggy.
 133 ;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
 134 (define (open-arity addr nreq nopt rest kw arities)
 135   (cons
 136    (cond
 137     (kw (list addr nreq nopt rest kw))
 138     (rest (list addr nreq nopt rest))
 139     (nopt (list addr nreq nopt))
 140     (nreq (list addr nreq))
 141     (else (list addr)))
 142    arities))
 143 (define (close-arity addr arities)
 144   (pmatch arities
 145     (() '())
 146     (((,start . ,tail) . ,rest)
 147      `((,start ,addr . ,tail) . ,rest))
 148     (else (error "bad arities" arities))))
 149 (define (begin-arity end start nreq nopt rest kw arities)
 150   (open-arity start nreq nopt rest kw (close-arity end arities)))
 151
 152 (define (compile-assembly glil)
 153   (receive (code . _)
 154       (glil->assembly glil #t '(()) '() '() #f '() -1)
 155     (car code)))
 156
 157 (define (glil->assembly glil toplevel? bindings
 158                         source-alist label-alist object-alist arities addr)
 159   (define (emit-code x)
 160     (values x bindings source-alist label-alist object-alist arities))
 161   (define (emit-code/object x object-alist)
 162     (values x bindings source-alist label-alist object-alist arities))
 163   (define (emit-code/arity x nreq nopt rest kw)
 164     (values x bindings source-alist label-alist object-alist
 165             (begin-arity addr (addr+ addr x) nreq nopt rest kw arities)))
 166
 167   (record-case glil
 168     ((<glil-program> meta body)
 169      (define (process-body)
 170        (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
 171                 (label-alist '()) (object-alist (if toplevel? #f '()))
 172                 (arities '()) (addr 0))
 173          (cond
 174           ((null? body)
 175            (values (reverse code)
 176                    (close-all-bindings bindings addr)
 177                    (limn-sources (reverse! source-alist))
 178                    (reverse label-alist)
 179                    (and object-alist (map car (reverse object-alist)))
 180                    (reverse (close-arity addr arities))
 181                    addr))
 182           (else
 183            (receive (subcode bindings source-alist label-alist object-alist
 184                      arities)
 185                (glil->assembly (car body) #f bindings
 186                                source-alist label-alist object-alist
 187                                arities addr)
 188              (lp (cdr body) (append (reverse subcode) code)
 189                  bindings source-alist label-alist object-alist arities
 190                  (addr+ addr subcode)))))))
 191
 192      (receive (code bindings sources labels objects arities len)
 193          (process-body)
 194        (let* ((meta (make-meta bindings sources arities meta))
 195               (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
 196               (prog `(load-program ,labels
 197                                   ,(+ len meta-pad)
 198                                   ,meta
 199                                   ,@code
 200                                   ,@(if meta
 201                                         (make-list meta-pad '(nop))
 202                                         '()))))
 203          (cond
 204           (toplevel?
 205            ;; toplevel bytecode isn't loaded by the vm, no way to do
 206            ;; object table or closure capture (not in the bytecode,
 207            ;; anyway)
 208            (emit-code (align-program prog addr)))
 209           (else
 210            (let ((table (make-object-table objects)))
 211              (cond
 212               (object-alist
 213                ;; if we are being compiled from something with an object
 214                ;; table, cache the program there
 215                (receive (i object-alist)
 216                    (object-index-and-alist (make-subprogram table prog)
 217                                            object-alist)
 218                  (emit-code/object `(,(if (< i 256)
 219                                           `(object-ref ,i)
 220                                           `(long-object-ref ,(quotient i 256)
 221                                                             ,(modulo i 256))))
 222                                    object-alist)))
 223               (else
 224                ;; otherwise emit a load directly
 225                (let ((table-code (dump-object table addr)))
 226                  (emit-code
 227                   `(,@table-code
 228                     ,@(align-program prog (addr+ addr table-code)))))))))))))
 229
 230     ((<glil-std-prelude> nreq nlocs else-label)
 231      (emit-code/arity
 232       `(,(if else-label
 233              `(br-if-nargs-ne ,(quotient nreq 256)
 234                               ,(modulo nreq 256)
 235                               ,else-label)
 236              `(assert-nargs-ee ,(quotient nreq 256)
 237                                ,(modulo nreq 256)))
 238         (reserve-locals ,(quotient nlocs 256)
 239                         ,(modulo nlocs 256)))
 240       nreq #f #f #f))
 241
 242     ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
 243      (let ((bind-required
 244             (if else-label
 245                 `((br-if-nargs-lt ,(quotient nreq 256)
 246                                   ,(modulo nreq 256)
 247                                   ,else-label))
 248                 `((assert-nargs-ge ,(quotient nreq 256)
 249                                    ,(modulo nreq 256)))))
 250            (bind-optionals
 251             (if (zero? nopt)
 252                 '()
 253                 `((bind-optionals ,(quotient (+ nopt nreq) 256)
 254                                   ,(modulo (+ nreq nopt) 256)))))
 255            (bind-rest
 256             (cond
 257              (rest
 258               `((push-rest ,(quotient (+ nreq nopt) 256)
 259                            ,(modulo (+ nreq nopt) 256))))
 260              (else
 261               (if else-label
 262                   `((br-if-nargs-gt ,(quotient (+ nreq nopt) 256)
 263                                     ,(modulo (+ nreq nopt) 256)
 264                                     ,else-label))
 265                   `((assert-nargs-ee ,(quotient (+ nreq nopt) 256)
 266                                      ,(modulo (+ nreq nopt) 256))))))))
 267        (emit-code/arity
 268         `(,@bind-required
 269           ,@bind-optionals
 270           ,@bind-rest
 271           (reserve-locals ,(quotient nlocs 256)
 272                           ,(modulo nlocs 256)))
 273         nreq nopt rest #f)))
 274
 275     ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
 276      (receive (kw-idx object-alist)
 277          (object-index-and-alist kw object-alist)
 278        (let* ((bind-required
 279                (if else-label
 280                    `((br-if-nargs-lt ,(quotient nreq 256)
 281                                      ,(modulo nreq 256)
 282                                      ,else-label))
 283                    `((assert-nargs-ge ,(quotient nreq 256)
 284                                       ,(modulo nreq 256)))))
 285               (ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw))))
 286               (bind-optionals-and-shuffle
 287                `((bind-optionals/shuffle
 288                   ,(quotient nreq 256)
 289                   ,(modulo nreq 256)
 290                   ,(quotient (+ nreq nopt) 256)
 291                   ,(modulo (+ nreq nopt) 256)
 292                   ,(quotient ntotal 256)
 293                   ,(modulo ntotal 256))))
 294               (bind-kw
 295                ;; when this code gets called, all optionals are filled
 296                ;; in, space has been made for kwargs, and the kwargs
 297                ;; themselves have been shuffled above the slots for all
 298                ;; req/opt/kwargs locals.
 299                `((bind-kwargs
 300                   ,(quotient kw-idx 256)
 301                   ,(modulo kw-idx 256)
 302                   ,(quotient ntotal 256)
 303                   ,(modulo ntotal 256)
 304                   ,(logior (if rest 2 0)
 305                            (if allow-other-keys? 1 0)))))
 306               (bind-rest
 307                (if rest
 308                    `((bind-rest ,(quotient ntotal 256)
 309                                 ,(modulo ntotal 256)
 310                                 ,(quotient rest 256)
 311                                 ,(modulo rest 256)))
 312                    '())))
 313
 314          (let ((code `(,@bind-required
 315                        ,@bind-optionals-and-shuffle
 316                        ,@bind-kw
 317                        ,@bind-rest
 318                        (reserve-locals ,(quotient nlocs 256)
 319                                        ,(modulo nlocs 256)))))
 320            (values code bindings source-alist label-alist object-alist
 321                    (begin-arity addr (addr+ addr code) nreq nopt rest
 322                                 (and kw (cons allow-other-keys? kw))
 323                                 arities))))))
 324
 325     ((<glil-bind> vars)
 326      (values '()
 327              (open-binding bindings vars addr)
 328              source-alist
 329              label-alist
 330              object-alist
 331              arities))
 332
 333     ((<glil-mv-bind> vars rest)
 334      (values `((truncate-values ,(length vars) ,(if rest 1 0)))
 335              (open-binding bindings vars addr)
 336              source-alist
 337              label-alist
 338              object-alist
 339              arities))
 340
 341     ((<glil-unbind>)
 342      (values '()
 343              (close-binding bindings addr)
 344              source-alist
 345              label-alist
 346              object-alist
 347              arities))
 348
 349     ((<glil-source> props)
 350      (values '()
 351              bindings
 352              (acons addr props source-alist)
 353              label-alist
 354              object-alist
 355              arities))
 356
 357     ((<glil-void>)
 358      (emit-code '((void))))
 359
 360     ((<glil-const> obj)
 361      (cond
 362       ((object->assembly obj)
 363        => (lambda (code)
 364             (emit-code (list code))))
 365       ((not object-alist)
 366        (emit-code (dump-object obj addr)))
 367       (else
 368        (receive (i object-alist)
 369            (object-index-and-alist obj object-alist)
 370          (emit-code/object (if (< i 256)
 371                                `((object-ref ,i))
 372                                `((long-object-ref ,(quotient i 256)
 373                                                   ,(modulo i 256))))
 374                            object-alist)))))
 375
 376     ((<glil-lexical> local? boxed? op index)
 377      (emit-code
 378       (if local?
 379           (if (< index 256)
 380               (case op
 381                 ((ref) (if boxed?
 382                            `((local-boxed-ref ,index))
 383                            `((local-ref ,index))))
 384                 ((set) (if boxed?
 385                            `((local-boxed-set ,index))
 386                            `((local-set ,index))))
 387                 ((box) `((box ,index)))
 388                 ((empty-box) `((empty-box ,index)))
 389                 ((fix) `((fix-closure 0 ,index)))
 390                 ((bound?) (if boxed?
 391                               `((local-ref ,index)
 392                                 (variable-bound?))
 393                               `((local-bound? ,index))))
 394                 (else (error "what" op)))
 395               (let ((a (quotient index 256))
 396                     (b (modulo index 256)))
 397                 `((,(case op
 398                       ((ref)
 399                        (if boxed?
 400                            `((long-local-ref ,a ,b)
 401                              (variable-ref))
 402                            `((long-local-ref ,a ,b))))
 403                       ((set)
 404                        (if boxed?
 405                            `((long-local-ref ,a ,b)
 406                              (variable-set))
 407                            `((long-local-set ,a ,b))))
 408                       ((box)
 409                        `((make-variable)
 410                          (variable-set)
 411                          (long-local-set ,a ,b)))
 412                       ((empty-box)
 413                        `((make-variable)
 414                          (long-local-set ,a ,b)))
 415                       ((fix)
 416                        `((fix-closure ,a ,b)))
 417                       ((bound?)
 418                        (if boxed?
 419                            `((long-local-ref ,a ,b)
 420                              (variable-bound?))
 421                            `((long-local-bound? ,a ,b))))
 422                       (else (error "what" op)))
 423                    ,index))))
 424           `((,(case op
 425                 ((ref) (if boxed? 'free-boxed-ref 'free-ref))
 426                 ((set) (if boxed? 'free-boxed-set (error "what." glil)))
 427                 (else (error "what" op)))
 428              ,index)))))
 429
 430     ((<glil-toplevel> op name)
 431      (case op
 432        ((ref set)
 433         (cond
 434          ((not object-alist)
 435           (emit-code `(,@(dump-object name addr)
 436                        (link-now)
 437                        ,(case op
 438                           ((ref) '(variable-ref))
 439                           ((set) '(variable-set))))))
 440          (else
 441           (receive (i object-alist)
 442               (object-index-and-alist (make-variable-cache-cell name)
 443                                       object-alist)
 444             (emit-code/object (if (< i 256)
 445                                   `((,(case op
 446                                         ((ref) 'toplevel-ref)
 447                                         ((set) 'toplevel-set))
 448                                      ,i))
 449                                   `((,(case op
 450                                         ((ref) 'long-toplevel-ref)
 451                                         ((set) 'long-toplevel-set))
 452                                      ,(quotient i 256)
 453                                      ,(modulo i 256))))
 454                               object-alist)))))
 455        ((define)
 456         (emit-code `(,@(dump-object name addr)
 457                      (define))))
 458        (else
 459         (error "unknown toplevel var kind" op name))))
 460
 461     ((<glil-module> op mod name public?)
 462      (let ((key (list mod name public?)))
 463        (case op
 464          ((ref set)
 465           (cond
 466            ((not object-alist)
 467             (emit-code `(,@(dump-object key addr)
 468                          (link-now)
 469                          ,(case op
 470                             ((ref) '(variable-ref))
 471                             ((set) '(variable-set))))))
 472            (else
 473             (receive (i object-alist)
 474                 (object-index-and-alist (make-variable-cache-cell key)
 475                                         object-alist)
 476               (emit-code/object (case op
 477                                   ((ref) `((toplevel-ref ,i)))
 478                                   ((set) `((toplevel-set ,i))))
 479                                 object-alist)))))
 480          (else
 481           (error "unknown module var kind" op key)))))
 482
 483     ((<glil-label> label)
 484      (let ((code (align-block addr)))
 485        (values code
 486                bindings
 487                source-alist
 488                (acons label (addr+ addr code) label-alist)
 489                object-alist
 490                arities)))
 491
 492     ((<glil-branch> inst label)
 493      (emit-code `((,inst ,label))))
 494
 495     ;; nargs is number of stack args to insn. probably should rename.
 496     ((<glil-call> inst nargs)
 497      (if (not (instruction? inst))
 498          (error "Unknown instruction:" inst))
 499      (let ((pops (instruction-pops inst)))
 500        (cond ((< pops 0)
 501               (case (instruction-length inst)
 502                 ((1) (emit-code `((,inst ,nargs))))
 503                 ((2) (emit-code `((,inst ,(quotient nargs 256)
 504                                          ,(modulo nargs 256)))))
 505                 (else (error "Unknown length for variable-arg instruction:"
 506                              inst (instruction-length inst)))))
 507              ((= pops nargs)
 508               (emit-code `((,inst))))
 509              (else
 510               (error "Wrong number of stack arguments to instruction:" inst nargs)))))
 511
 512     ((<glil-mv-call> nargs ra)
 513      (emit-code `((mv-call ,nargs ,ra))))))
 514
 515 (define (dump-object x addr)
 516   (define (too-long x)
 517     (error (string-append x " too long")))
 518
 519   (cond
 520    ((object->assembly x) => list)
 521    ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
 522    ((subprogram? x)
 523     (let ((table-code (dump-object (subprogram-table x) addr)))
 524       `(,@table-code
 525         ,@(align-program (subprogram-prog x)
 526                          (addr+ addr table-code)))))
 527    ((number? x)
 528     `((load-number ,(number->string x))))
 529    ((string? x)
 530     (case (string-bytes-per-char x)
 531       ((1) `((load-string ,x)))
 532       ((4) (align-code `(load-wide-string ,x) addr 4 4))
 533       (else (error "bad string bytes per char" x))))
 534    ((symbol? x)
 535     (let ((str (symbol->string x)))
 536       (case (string-bytes-per-char str)
 537         ((1) `((load-symbol ,str)))
 538         ((4) `(,@(dump-object str addr)
 539                (make-symbol)))
 540         (else (error "bad string bytes per char" str)))))
 541    ((keyword? x)
 542     `(,@(dump-object (keyword->symbol x) addr)
 543       (make-keyword)))
 544    ((list? x)
 545     (let ((tail (let ((len (length x)))
 546                   (if (>= len 65536) (too-long "list"))
 547                   `((list ,(quotient len 256) ,(modulo len 256))))))
 548       (let dump-objects ((objects x) (codes '()) (addr addr))
 549         (if (null? objects)
 550             (fold append tail codes)
 551             (let ((code (dump-object (car objects) addr)))
 552               (dump-objects (cdr objects) (cons code codes)
 553                             (addr+ addr code)))))))
 554    ((pair? x)
 555     (let ((kar (dump-object (car x) addr)))
 556       `(,@kar
 557         ,@(dump-object (cdr x) (addr+ addr kar))
 558         (cons))))
 559    ((vector? x)
 560     (let* ((len (vector-length x))
 561            (tail (if (>= len 65536)
 562                      (too-long "vector")
 563                      `((vector ,(quotient len 256) ,(modulo len 256))))))
 564       (let dump-objects ((i 0) (codes '()) (addr addr))
 565         (if (>= i len)
 566             (fold append tail codes)
 567             (let ((code (dump-object (vector-ref x i) addr)))
 568               (dump-objects (1+ i) (cons code codes)
 569                             (addr+ addr code)))))))
 570    ((and (array? x) (symbol? (array-type x)))
 571     (let* ((type (dump-object (array-type x) addr))
 572            (shape (dump-object (array-shape x) (addr+ addr type))))
 573       `(,@type
 574         ,@shape
 575         ,@(align-code
 576            `(load-array ,(uniform-array->bytevector x))
 577            (addr+ (addr+ addr type) shape)
 578            8
 579            4))))
 580    (else
 581     (error "assemble: unrecognized object" x))))
 582