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 (map assembly-pack x) bindings source-alist label-alist object-alist))
 141   (define (emit-code/object x object-alist)
 142     (values (map assembly-pack 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 ((prog `(load-program ,nargs ,nrest ,nlocs ,labels
 168                                   ,len
 169                                   ,(make-meta bindings sources meta)
 170                                   . ,code)))
 171          (cond
 172           (toplevel?
 173            ;; toplevel bytecode isn't loaded by the vm, no way to do
 174            ;; object table or closure capture (not in the bytecode,
 175            ;; anyway)
 176            (emit-code (align-program prog addr)))
 177           (else
 178            (let ((table (dump-object (make-object-table objects) addr)))
 179              (cond
 180               (object-alist
 181                ;; if we are being compiled from something with an object
 182                ;; table, cache the program there
 183                (receive (i object-alist)
 184                    (object-index-and-alist (make-subprogram table prog)
 185                                            object-alist)
 186                  (emit-code/object `(,(if (< i 256)
 187                                           `(object-ref ,i)
 188                                           `(long-object-ref ,(quotient i 256)
 189                                                             ,(modulo i 256))))
 190                                    object-alist)))
 191               (else
 192                ;; otherwise emit a load directly
 193                (emit-code `(,@table ,@(align-program prog (addr+ addr table))))))))))))
 194
 195
 196     ((<glil-bind> vars)
 197      (values '()
 198              (open-binding bindings vars addr)
 199              source-alist
 200              label-alist
 201              object-alist))
 202
 203     ((<glil-mv-bind> vars rest)
 204      (values `((truncate-values ,(length vars) ,(if rest 1 0)))
 205              (open-binding bindings vars addr)
 206              source-alist
 207              label-alist
 208              object-alist))
 209
 210     ((<glil-unbind>)
 211      (values '()
 212              (close-binding bindings addr)
 213              source-alist
 214              label-alist
 215              object-alist))
 216
 217     ((<glil-source> props)
 218      (values '()
 219              bindings
 220              (acons addr props source-alist)
 221              label-alist
 222              object-alist))
 223
 224     ((<glil-void>)
 225      (emit-code '((void))))
 226
 227     ((<glil-const> obj)
 228      (cond
 229       ((object->assembly obj)
 230        => (lambda (code)
 231             (emit-code (list code))))
 232       ((not object-alist)
 233        (emit-code (dump-object obj addr)))
 234       (else
 235        (receive (i object-alist)
 236            (object-index-and-alist obj object-alist)
 237          (emit-code/object (if (< i 256)
 238                                `((object-ref ,i))
 239                                `((long-object-ref ,(quotient i 256)
 240                                                   ,(modulo i 256))))
 241                            object-alist)))))
 242
 243     ((<glil-lexical> local? boxed? op index)
 244      (emit-code
 245       `((,(if local?
 246               (case op
 247                 ((ref) (if boxed? 'local-boxed-ref 'local-ref))
 248                 ((set) (if boxed? 'local-boxed-set 'local-set))
 249                 ((box) 'box)
 250                 ((empty-box) 'empty-box)
 251                 (else (error "what" op)))
 252               (case op
 253                 ((ref) (if boxed? 'free-boxed-ref 'free-ref))
 254                 ((set) (if boxed? 'free-boxed-set (error "what." glil)))
 255                 (else (error "what" op))))
 256          ,index))))
 257
 258     ((<glil-toplevel> op name)
 259      (case op
 260        ((ref set)
 261         (cond
 262          ((not object-alist)
 263           (emit-code `(,@(dump-object name addr)
 264                        (link-now)
 265                        ,(case op
 266                           ((ref) '(variable-ref))
 267                           ((set) '(variable-set))))))
 268          (else
 269           (receive (i object-alist)
 270               (object-index-and-alist (make-variable-cache-cell name)
 271                                       object-alist)
 272             (emit-code/object (if (< i 256)
 273                                   `((,(case op
 274                                         ((ref) 'toplevel-ref)
 275                                         ((set) 'toplevel-set))
 276                                      ,i))
 277                                   `((,(case op
 278                                         ((ref) 'long-toplevel-ref)
 279                                         ((set) 'long-toplevel-set))
 280                                      ,(quotient i 256)
 281                                      ,(modulo i 256))))
 282                               object-alist)))))
 283        ((define)
 284         (emit-code `((define ,(symbol->string name))
 285                      (variable-set))))
 286        (else
 287         (error "unknown toplevel var kind" op name))))
 288
 289     ((<glil-module> op mod name public?)
 290      (let ((key (list mod name public?)))
 291        (case op
 292          ((ref set)
 293           (cond
 294            ((not object-alist)
 295             (emit-code `(,@(dump-object key addr)
 296                          (link-now)
 297                          ,(case op
 298                             ((ref) '(variable-ref))
 299                             ((set) '(variable-set))))))
 300            (else
 301             (receive (i object-alist)
 302                 (object-index-and-alist (make-variable-cache-cell key)
 303                                         object-alist)
 304               (emit-code/object (case op
 305                                   ((ref) `((toplevel-ref ,i)))
 306                                   ((set) `((toplevel-set ,i))))
 307                                 object-alist)))))
 308          (else
 309           (error "unknown module var kind" op key)))))
 310
 311     ((<glil-label> label)
 312      (values '()
 313              bindings
 314              source-alist
 315              (acons label addr label-alist)
 316              object-alist))
 317
 318     ((<glil-branch> inst label)
 319      (emit-code `((,inst ,label))))
 320
 321     ;; nargs is number of stack args to insn. probably should rename.
 322     ((<glil-call> inst nargs)
 323      (if (not (instruction? inst))
 324          (error "Unknown instruction:" inst))
 325      (let ((pops (instruction-pops inst)))
 326        (cond ((< pops 0)
 327               (case (instruction-length inst)
 328                 ((1) (emit-code `((,inst ,nargs))))
 329                 ((2) (emit-code `((,inst ,(quotient nargs 256)
 330                                          ,(modulo nargs 256)))))
 331                 (else (error "Unknown length for variable-arg instruction:"
 332                              inst (instruction-length inst)))))
 333              ((= pops nargs)
 334               (emit-code `((,inst))))
 335              (else
 336               (error "Wrong number of stack arguments to instruction:" inst nargs)))))
 337
 338     ((<glil-mv-call> nargs ra)
 339      (emit-code `((mv-call ,nargs ,ra))))))
 340
 341 (define (dump-object x addr)
 342   (define (too-long x)
 343     (error (string-append x " too long")))
 344
 345   (cond
 346    ((object->assembly x) => list)
 347    ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
 348    ((subprogram? x)
 349     `(,@(subprogram-table x)
 350       ,@(align-program (subprogram-prog x)
 351                        (addr+ addr (subprogram-table x)))))
 352    ((number? x)
 353     `((load-number ,(number->string x))))
 354    ((string? x)
 355     `((load-string ,x)))
 356    ((symbol? x)
 357     `((load-symbol ,(symbol->string x))))
 358    ((keyword? x)
 359     `((load-keyword ,(symbol->string (keyword->symbol x)))))
 360    ((list? x)
 361     (let ((tail (let ((len (length x)))
 362                   (if (>= len 65536) (too-long "list"))
 363                   `((list ,(quotient len 256) ,(modulo len 256))))))
 364       (let dump-objects ((objects x) (codes '()) (addr addr))
 365         (if (null? objects)
 366             (fold append tail codes)
 367             (let ((code (dump-object (car objects) addr)))
 368               (dump-objects (cdr objects) (cons code codes)
 369                             (addr+ addr code)))))))
 370    ((pair? x)
 371     (let ((kar (dump-object (car x) addr)))
 372       `(,@kar
 373         ,@(dump-object (cdr x) (addr+ addr kar))
 374         (cons))))
 375    ((vector? x)
 376     (let* ((len (vector-length x))
 377            (tail (if (>= len 65536)
 378                      (too-long "vector")
 379                      `((vector ,(quotient len 256) ,(modulo len 256))))))
 380       (let dump-objects ((i 0) (codes '()) (addr addr))
 381         (if (>= i len)
 382             (fold append tail codes)
 383             (let ((code (dump-object (vector-ref x i) addr)))
 384               (dump-objects (1+ i) (cons code codes)
 385                             (addr+ addr code)))))))
 386    ((and (array? x) (symbol? (array-type x)))
 387     (let* ((type (dump-object (array-type x) addr))
 388            (shape (dump-object (array-shape x) (addr+ addr type))))
 389       `(,@type
 390         ,@shape
 391         ,@(align-code
 392            `(load-array ,(uniform-array->bytevector x))
 393            (addr+ (addr+ addr type) shape)
 394            8
 395            4))))
 396    (else
 397     (error "assemble: unrecognized object" x))))
 398