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 tail)
  72   (if (and (null? bindings) (null? sources) (null? tail))
  73       #f
  74       (compile-assembly
  75        (make-glil-program 0 0 0 '()
  76                           (list
  77                            (make-glil-const `(,bindings ,sources ,@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
 129 (define (compile-assembly glil)
 130   (receive (code . _)
 131       (glil->assembly glil #t '(()) '() '() #f -1)
 132     (car code)))
 133 (define (make-object-table objects)
 134   (and (not (null? objects))
 135        (list->vector (cons #f objects))))
 136
 137 (define (glil->assembly glil toplevel? bindings
 138                         source-alist label-alist object-alist addr)
 139   (define (emit-code x)
 140     (values x bindings source-alist label-alist object-alist))
 141   (define (emit-code/object x object-alist)
 142     (values x bindings source-alist label-alist object-alist))
 143
 144   (record-case glil
 145     ((<glil-program> nargs nrest nlocs meta body)
 146      (define (process-body)
 147        (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
 148                 (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
 149          (cond
 150           ((null? body)
 151            (values (reverse code)
 152                    (close-all-bindings bindings addr)
 153                    (limn-sources (reverse! source-alist))
 154                    (reverse label-alist)
 155                    (and object-alist (map car (reverse object-alist)))
 156                    addr))
 157           (else
 158            (receive (subcode bindings source-alist label-alist object-alist)
 159                (glil->assembly (car body) #f bindings
 160                                source-alist label-alist object-alist addr)
 161              (lp (cdr body) (append (reverse subcode) code)
 162                  bindings source-alist label-alist object-alist
 163                  (addr+ addr subcode)))))))
 164
 165      (receive (code bindings sources labels objects len)
 166          (process-body)
 167        (let* ((meta (make-meta bindings sources meta))
 168               (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
 169               (prog `(load-program ,nargs ,nrest ,nlocs ,labels
 170                                   ,(+ len meta-pad)
 171                                   ,meta
 172                                   ,@code
 173                                   ,@(if meta
 174                                         (make-list meta-pad '(nop))
 175                                         '()))))
 176          (cond
 177           (toplevel?
 178            ;; toplevel bytecode isn't loaded by the vm, no way to do
 179            ;; object table or closure capture (not in the bytecode,
 180            ;; anyway)
 181            (emit-code (align-program prog addr)))
 182           (else
 183            (let ((table (make-object-table objects)))
 184              (cond
 185               (object-alist
 186                ;; if we are being compiled from something with an object
 187                ;; table, cache the program there
 188                (receive (i object-alist)
 189                    (object-index-and-alist (make-subprogram table prog)
 190                                            object-alist)
 191                  (emit-code/object `(,(if (< i 256)
 192                                           `(object-ref ,i)
 193                                           `(long-object-ref ,(quotient i 256)
 194                                                             ,(modulo i 256))))
 195                                    object-alist)))
 196               (else
 197                ;; otherwise emit a load directly
 198                (let ((table-code (dump-object table addr)))
 199                  (emit-code
 200                   `(,@table-code
 201                     ,@(align-program prog (addr+ addr table-code)))))))))))))
 202
 203     ((<glil-bind> vars)
 204      (values '()
 205              (open-binding bindings vars addr)
 206              source-alist
 207              label-alist
 208              object-alist))
 209
 210     ((<glil-mv-bind> vars rest)
 211      (values `((truncate-values ,(length vars) ,(if rest 1 0)))
 212              (open-binding bindings vars addr)
 213              source-alist
 214              label-alist
 215              object-alist))
 216
 217     ((<glil-unbind>)
 218      (values '()
 219              (close-binding bindings addr)
 220              source-alist
 221              label-alist
 222              object-alist))
 223
 224     ((<glil-source> props)
 225      (values '()
 226              bindings
 227              (acons addr props source-alist)
 228              label-alist
 229              object-alist))
 230
 231     ((<glil-void>)
 232      (emit-code '((void))))
 233
 234     ((<glil-const> obj)
 235      (cond
 236       ((object->assembly obj)
 237        => (lambda (code)
 238             (emit-code (list code))))
 239       ((not object-alist)
 240        (emit-code (dump-object obj addr)))
 241       (else
 242        (receive (i object-alist)
 243            (object-index-and-alist obj object-alist)
 244          (emit-code/object (if (< i 256)
 245                                `((object-ref ,i))
 246                                `((long-object-ref ,(quotient i 256)
 247                                                   ,(modulo i 256))))
 248                            object-alist)))))
 249
 250     ((<glil-lexical> local? boxed? op index)
 251      (emit-code
 252       (if local?
 253           (if (< index 256)
 254               (case op
 255                 ((ref) (if boxed?
 256                            `((local-boxed-ref ,index))
 257                            `((local-ref ,index))))
 258                 ((set) (if boxed?
 259                            `((local-boxed-set ,index))
 260                            `((local-set ,index))))
 261                 ((box) `((box ,index)))
 262                 ((empty-box) `((empty-box ,index)))
 263                 ((fix) `((fix-closure 0 ,index)))
 264                 (else (error "what" op)))
 265               (let ((a (quotient i 256))
 266                     (b (modulo i 256)))
 267                 `((,(case op
 268                       ((ref)
 269                        (if boxed?
 270                            `((long-local-ref ,a ,b)
 271                              (variable-ref))
 272                            `((long-local-ref ,a ,b))))
 273                       ((set)
 274                        (if boxed?
 275                            `((long-local-ref ,a ,b)
 276                              (variable-set))
 277                            `((long-local-set ,a ,b))))
 278                       ((box)
 279                        `((make-variable)
 280                          (variable-set)
 281                          (long-local-set ,a ,b)))
 282                       ((empty-box)
 283                        `((make-variable)
 284                          (long-local-set ,a ,b)))
 285                       ((fix)
 286                        `((fix-closure ,a ,b)))
 287                       (else (error "what" op)))
 288                    ,index))))
 289           `((,(case op
 290                 ((ref) (if boxed? 'free-boxed-ref 'free-ref))
 291                 ((set) (if boxed? 'free-boxed-set (error "what." glil)))
 292                 (else (error "what" op)))
 293              ,index)))))
 294
 295     ((<glil-toplevel> op name)
 296      (case op
 297        ((ref set)
 298         (cond
 299          ((not object-alist)
 300           (emit-code `(,@(dump-object name addr)
 301                        (link-now)
 302                        ,(case op
 303                           ((ref) '(variable-ref))
 304                           ((set) '(variable-set))))))
 305          (else
 306           (receive (i object-alist)
 307               (object-index-and-alist (make-variable-cache-cell name)
 308                                       object-alist)
 309             (emit-code/object (if (< i 256)
 310                                   `((,(case op
 311                                         ((ref) 'toplevel-ref)
 312                                         ((set) 'toplevel-set))
 313                                      ,i))
 314                                   `((,(case op
 315                                         ((ref) 'long-toplevel-ref)
 316                                         ((set) 'long-toplevel-set))
 317                                      ,(quotient i 256)
 318                                      ,(modulo i 256))))
 319                               object-alist)))))
 320        ((define)
 321         (emit-code `(,@(dump-object name addr)
 322                      (define))))
 323        (else
 324         (error "unknown toplevel var kind" op name))))
 325
 326     ((<glil-module> op mod name public?)
 327      (let ((key (list mod name public?)))
 328        (case op
 329          ((ref set)
 330           (cond
 331            ((not object-alist)
 332             (emit-code `(,@(dump-object key addr)
 333                          (link-now)
 334                          ,(case op
 335                             ((ref) '(variable-ref))
 336                             ((set) '(variable-set))))))
 337            (else
 338             (receive (i object-alist)
 339                 (object-index-and-alist (make-variable-cache-cell key)
 340                                         object-alist)
 341               (emit-code/object (case op
 342                                   ((ref) `((toplevel-ref ,i)))
 343                                   ((set) `((toplevel-set ,i))))
 344                                 object-alist)))))
 345          (else
 346           (error "unknown module var kind" op key)))))
 347
 348     ((<glil-label> label)
 349      (let ((code (align-block addr)))
 350        (values code
 351                bindings
 352                source-alist
 353                (acons label (addr+ addr code) label-alist)
 354                object-alist)))
 355
 356     ((<glil-branch> inst label)
 357      (emit-code `((,inst ,label))))
 358
 359     ;; nargs is number of stack args to insn. probably should rename.
 360     ((<glil-call> inst nargs)
 361      (if (not (instruction? inst))
 362          (error "Unknown instruction:" inst))
 363      (let ((pops (instruction-pops inst)))
 364        (cond ((< pops 0)
 365               (case (instruction-length inst)
 366                 ((1) (emit-code `((,inst ,nargs))))
 367                 ((2) (emit-code `((,inst ,(quotient nargs 256)
 368                                          ,(modulo nargs 256)))))
 369                 (else (error "Unknown length for variable-arg instruction:"
 370                              inst (instruction-length inst)))))
 371              ((= pops nargs)
 372               (emit-code `((,inst))))
 373              (else
 374               (error "Wrong number of stack arguments to instruction:" inst nargs)))))
 375
 376     ((<glil-mv-call> nargs ra)
 377      (emit-code `((mv-call ,nargs ,ra))))))
 378
 379 (define (dump-object x addr)
 380   (define (too-long x)
 381     (error (string-append x " too long")))
 382
 383   (cond
 384    ((object->assembly x) => list)
 385    ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
 386    ((subprogram? x)
 387     (let ((table-code (dump-object (subprogram-table x) addr)))
 388       `(,@table-code
 389         ,@(align-program (subprogram-prog x)
 390                          (addr+ addr table-code)))))
 391    ((number? x)
 392     `((load-number ,(number->string x))))
 393    ((string? x)
 394     (case (string-bytes-per-char x)
 395       ((1) `((load-string ,x)))
 396       ((4) (align-code `(load-wide-string ,x) addr 4 4))
 397       (else (error "bad string bytes per char" x))))
 398    ((symbol? x)
 399     (let ((str (symbol->string x)))
 400       (case (string-bytes-per-char str)
 401         ((1) `((load-symbol ,str)))
 402         ((4) `(,@(dump-object str addr)
 403                (make-symbol)))
 404         (else (error "bad string bytes per char" str)))))
 405    ((keyword? x)
 406     `(,@(dump-object (keyword->symbol x) addr)
 407       (make-keyword)))
 408    ((list? x)
 409     (let ((tail (let ((len (length x)))
 410                   (if (>= len 65536) (too-long "list"))
 411                   `((list ,(quotient len 256) ,(modulo len 256))))))
 412       (let dump-objects ((objects x) (codes '()) (addr addr))
 413         (if (null? objects)
 414             (fold append tail codes)
 415             (let ((code (dump-object (car objects) addr)))
 416               (dump-objects (cdr objects) (cons code codes)
 417                             (addr+ addr code)))))))
 418    ((pair? x)
 419     (let ((kar (dump-object (car x) addr)))
 420       `(,@kar
 421         ,@(dump-object (cdr x) (addr+ addr kar))
 422         (cons))))
 423    ((vector? x)
 424     (let* ((len (vector-length x))
 425            (tail (if (>= len 65536)
 426                      (too-long "vector")
 427                      `((vector ,(quotient len 256) ,(modulo len 256))))))
 428       (let dump-objects ((i 0) (codes '()) (addr addr))
 429         (if (>= i len)
 430             (fold append tail codes)
 431             (let ((code (dump-object (vector-ref x i) addr)))
 432               (dump-objects (1+ i) (cons code codes)
 433                             (addr+ addr code)))))))
 434    ((and (array? x) (symbol? (array-type x)))
 435     (let* ((type (dump-object (array-type x) addr))
 436            (shape (dump-object (array-shape x) (addr+ addr type))))
 437       `(,@type
 438         ,@shape
 439         ,@(align-code
 440            `(load-array ,(uniform-array->bytevector x))
 441            (addr+ (addr+ addr type) shape)
 442            8
 443            4))))
 444    (else
 445     (error "assemble: unrecognized object" x))))
 446