module/language/glil/compile-assembly.scm

   1 ;;; Guile VM assembler
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program 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
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (language glil compile-assembly)
  23   #:use-module (system base syntax)
  24   #:use-module (system base pmatch)
  25   #:use-module (language glil)
  26   #:use-module (language assembly)
  27   #:use-module (system vm instruction)
  28   #:use-module ((system vm program) #:select (make-binding))
  29   #:use-module (system vm conv) ;; fixme: move this module
  30   #:use-module (ice-9 receive)
  31   #:use-module ((srfi srfi-1) #:select (fold))
  32   #:export (compile-assembly))
  33
  34 ;; Variable cache cells go in the object table, and serialize as their
  35 ;; keys. The reason we wrap the keys in these records is so they don't
  36 ;; compare as `equal?' to other objects in the object table.
  37 ;;
  38 ;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?)
  39
  40 (define-record <variable-cache-cell> key)
  41
  42 ;; Subprograms can be loaded into an object table as well. We need a
  43 ;; disjoint type here too.
  44
  45 (define-record <subprogram> code)
  46
  47
  48 ;; A metadata thunk has no object table, so it is very quick to load.
  49 (define (make-meta bindings sources tail)
  50   (if (and (null? bindings) (null? sources) (null? tail))
  51       #f
  52       (make-subprogram
  53        (compile-assembly
  54         (make-glil-program 0 0 0 0 #f
  55                            (list
  56                             (make-glil-const `(,bindings ,sources ,@tail))
  57                             (make-glil-call 'return 0)))))))
  58
  59 ;; A functional stack of names of live variables.
  60 (define (make-open-binding name ext? index)
  61   (list name ext? index))
  62 (define (make-closed-binding open-binding start end)
  63   (make-binding (car open-binding) (cadr open-binding)
  64                 (caddr open-binding) start end))
  65 (define (open-binding bindings vars nargs start)
  66   (cons
  67    (acons start
  68           (map
  69            (lambda (v)
  70              (pmatch v
  71                ((,name argument ,i) (make-open-binding name #f i))
  72                ((,name local ,i) (make-open-binding name #f (+ nargs i)))
  73                ((,name external ,i) (make-open-binding name #t i))
  74                (else (error "unknown binding type" name type))))
  75            vars)
  76           (car bindings))
  77    (cdr bindings)))
  78 (define (close-binding bindings end)
  79   (pmatch bindings
  80     ((((,start . ,closing) . ,open) . ,closed)
  81      (cons open
  82            (fold (lambda (o tail)
  83                    ;; the cons is for dsu sort
  84                    (acons start (make-closed-binding o start end)
  85                           tail))
  86                  closed
  87                  closing)))
  88     (else (error "broken bindings" bindings))))
  89 (define (close-all-bindings bindings end)
  90   (if (null? (car bindings))
  91       (map cdr
  92            (stable-sort (reverse (cdr bindings))
  93                         (lambda (x y) (< (car x) (car y)))))
  94       (close-all-bindings (close-binding bindings end) end)))
  95
  96 ;; A functional object table.
  97 (define *module-and-meta* 2)
  98 (define (assoc-ref-or-acons x alist make-y)
  99   (cond ((assoc-ref x alist)
 100          => (lambda (y) (values y alist)))
 101         (else
 102          (let ((y (make-y x alist)))
 103          (values y (acons x y alist))))))
 104 (define (object-index-and-alist x alist)
 105   (assoc-ref-or-acons x alist
 106                       (lambda (x alist)
 107                         (+ (length alist) *module-and-meta*))))
 108
 109 (define (compile-assembly glil)
 110   (receive (code . _)
 111       (glil->assembly glil 0 '() '(()) '() '() #f 0)
 112     (car code)))
 113 (define (make-object-table objects meta)
 114   (and (or meta (not (null? objects)))
 115        (list->vector (cons* #f meta objects))))
 116
 117 (define (glil->assembly glil nargs nexts-stack bindings
 118                         source-alist label-alist object-alist addr)
 119   (define (emit-code x)
 120     (values x bindings source-alist label-alist object-alist))
 121   (define (emit-code/object x object-alist)
 122     (values x bindings source-alist label-alist object-alist))
 123
 124   (record-case glil
 125     ((<glil-program> nargs nrest nlocs nexts meta body)
 126      (define (process-body)
 127        (let ((nexts-stack (cons nexts nexts-stack)))
 128          (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
 129                   (label-alist '()) (object-alist (if (null? (cdr nexts-stack)) #f '())) (addr 0))
 130            (cond
 131             ((null? body)
 132              (values (reverse code)
 133                      (close-all-bindings bindings addr)
 134                      (reverse source-alist)
 135                      (reverse label-alist)
 136                      (and object-alist (map car (reverse object-alist)))
 137                      addr))
 138             (else
 139              (receive (subcode bindings source-alist label-alist object-alist)
 140                  (glil->assembly (car body) nargs nexts-stack bindings
 141                                  source-alist label-alist object-alist addr)
 142                (lp (cdr body) (append (reverse subcode) code)
 143                    bindings source-alist label-alist object-alist
 144                    (apply + addr (map byte-length subcode)))))))))
 145
 146      ;; include len and labels
 147      (receive (code bindings sources labels objects subaddr)
 148          (process-body)
 149        (let ((asm `(,@(if objects
 150                           (dump-object
 151                            (make-object-table objects
 152                                               (make-meta bindings sources meta))
 153                            addr)
 154                           '())
 155                     (assembly ,nargs ,nrest ,nlocs ,nexts
 156                               ,labels ,subaddr
 157                               . ,code)
 158                     ,@(if closure? '((make-closure)) '()))))
 159          (cond ((or (null? nexts-stack) (not object-alist))
 160                 (emit-code asm))
 161                (else
 162                 (receive (i object-alist)
 163                     (object-index-and-alist (make-subprogram asm) object-alist)
 164                   (emit-code/object '((object-ref ,i)) object-alist)))))))
 165
 166     ((<glil-bind> vars)
 167      (values '()
 168              (open-binding bindings vars nargs addr)
 169              source-alist
 170              label-alist
 171              object-alist))
 172
 173     ((<glil-mv-bind> vars rest)
 174      (values `((truncate-values ,(length vars) ,(if rest 1 0)))
 175              (open-binding bindings vars nargs addr)
 176              source-alist
 177              label-alist
 178              object-alist))
 179
 180     ((<glil-unbind>)
 181      (values '()
 182              (close-binding bindings addr)
 183              source-alist
 184              label-alist
 185              object-alist))
 186
 187     ((<glil-source> loc)
 188      (values '()
 189              bindings
 190              (acons addr loc source-alist)
 191              label-alist
 192              object-alist))
 193
 194     ((<glil-void>)
 195      (emit-code '((void))))
 196
 197     ((<glil-const> obj)
 198      (cond
 199       ((object->code obj)
 200        => (lambda (code)
 201             (emit-code (list code))))
 202       ((not object-alist)
 203        (emit-code (dump-object obj addr)))
 204       (else
 205        (receive (i object-alist)
 206            (object-index-and-alist obj object-alist)
 207          (emit-code/object `((object-ref ,i))
 208                            object-alist)))))
 209
 210     ((<glil-argument> op index)
 211      (emit-code (if (eq? op 'ref)
 212                     `((local-ref ,index))
 213                     `((local-set ,index)))))
 214
 215     ((<glil-local> op index)
 216      (emit-code (if (eq? op 'ref)
 217                     `((local-ref ,(+ nargs index)))
 218                     `((local-set ,(+ nargs index))))))
 219
 220     ((<glil-external> op depth index)
 221      (emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
 222                   (if (> d 0)
 223                       (lp (1- d) (+ n (car stack)) (cdr stack))
 224                       (if (eq? op 'ref)
 225                           `((external-ref ,(+ n index)))
 226                           `((external-set ,(+ n index))))))))
 227
 228     ((<glil-toplevel> op name)
 229      (case op
 230        ((ref set)
 231         (cond
 232          ((not object-alist)
 233           (emit-code `(,@(dump-object name addr)
 234                        (link-now)
 235                        ,(case op
 236                           ((ref) '(variable-ref))
 237                           ((set) '(variable-set))))))
 238          (else
 239           (receive (i object-alist)
 240               (object-index-and-alist (make-variable-cache-cell name)
 241                                       object-alist)
 242             (emit-code/object (case op
 243                                 ((ref) `((toplevel-ref ,i)))
 244                                 ((set) `((toplevel-set ,i))))
 245                               object-alist)))))
 246        ((define)
 247         (emit-code `((define ,(symbol->string name))
 248                      (variable-set))))
 249        (else
 250         (error "unknown toplevel var kind" op name))))
 251
 252     ((<glil-module> op mod name public?)
 253      (let ((key (list mod name public?)))
 254        (case op
 255          ((ref set)
 256           (cond
 257            ((not object-alist)
 258             (emit-code `(,@(dump-object key addr)
 259                          (link-now)
 260                          ,(case op
 261                             ((ref) '(variable-ref))
 262                             ((set) '(variable-set))))))
 263            (else
 264             (receive (i object-alist)
 265                 (object-index-and-alist (make-variable-cache-cell name)
 266                                         object-alist)
 267               (emit-code/object (case op
 268                                   ((ref) `((toplevel-ref ,i)))
 269                                   ((set) `((toplevel-set ,i))))
 270                                 object-alist)))))
 271          (else
 272           (error "unknown module var kind" op key)))))
 273
 274     ((<glil-label> label)
 275      (values '()
 276              bindings
 277              source-alist
 278              (acons label addr label-alist)
 279              object-alist))
 280
 281     ((<glil-branch> inst label)
 282      (emit-code `((,inst ,label))))
 283
 284     ;; nargs is number of stack args to insn. probably should rename.
 285     ((<glil-call> inst nargs)
 286      (if (not (instruction? inst))
 287          (error "Unknown instruction:" inst))
 288      (let ((pops (instruction-pops inst)))
 289        (cond ((< pops 0)
 290               (emit-code `((,inst ,nargs))))
 291              ((= pops nargs)
 292               (emit-code `((,inst))))
 293              (else
 294               (error "Wrong number of stack arguments to instruction:" inst nargs)))))
 295
 296     ((<glil-mv-call> nargs ra)
 297      (emit-code `((mv-call ,nargs ,ra))))))
 298
 299 ;; addr is currently unused, but could be used to align data in the
 300 ;; instruction stream.
 301 (define (dump-object x addr)
 302   (define (too-long x)
 303     (error (string-append x " too long")))
 304
 305   (let dump ((x x))
 306     (cond
 307      ((object->code x) => list)
 308      ((variable-cache-cell? x) (dump (variable-cache-cell-key x)))
 309      ((subprogram? x) (list (subprogram-code x)))
 310      ((and (integer? x) (exact? x))
 311       (let ((str (do ((n x (quotient n 256))
 312                       (l '() (cons (modulo n 256) l)))
 313                      ((= n 0)
 314                       (apply u8vector l)))))
 315         `((load-integer ,str))))
 316      ((number? x)
 317       `((load-number ,(number->string x))))
 318      ((string? x)
 319       `((load-string ,x)))
 320      ((symbol? x)
 321       `((load-symbol ,(symbol->string x))))
 322      ((keyword? x)
 323       `((load-keyword ,(symbol->string (keyword->symbol x)))))
 324      ((list? x)
 325       (fold (lambda (x y)
 326               (append (dump x) y))
 327             (let ((len (length x)))
 328               (if (>= len 65536) (too-long "list"))
 329               `((list ,(quotient len 256) ,(modulo len 256))))
 330             x))
 331      ((pair? x)
 332       `(,@(dump (car x))
 333         ,@(dump (cdr x))
 334         (cons)))
 335      ((vector? x)
 336       (fold (lambda (x y)
 337               (append (dump x) y))
 338             (let ((len (vector-length x)))
 339               (if (>= len 65536) (too-long "vector"))
 340               `((vector ,(quotient len 256) ,(modulo len 256))))
 341             (vector->list x)))
 342      (else
 343       (error "assemble: unrecognized object" x)))))
 344