module/system/vm/assemble.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 (system vm assemble)
  23   :use-syntax (system base syntax)
  24   :use-module (system base module)
  25   :use-module (system il glil)
  26   :use-module (system vm core)
  27   :use-module (system vm conv)
  28   :use-module (ice-9 match)
  29   :use-module (ice-9 regex)
  30   :use-module (ice-9 common-list)
  31   :export (assemble))
  32
  33 (define (assemble glil env . opts)
  34   (dump (codegen (preprocess glil #f) #t)))
  35
  36 \f
  37 ;;;
  38 ;;; Types
  39 ;;;
  40
  41 (define-structure (<vm-asm> venv glil body))
  42 (define-structure (venv parent nexts closure?))
  43 (define-structure (vmod id))
  44 (define-structure (vlink module name))
  45 (define-structure (bytespec nargs nrest nlocs bytes objs))
  46
  47 \f
  48 ;;;
  49 ;;; Stage 1: Preprocess
  50 ;;;
  51
  52 (define (preprocess x e)
  53   (match x
  54     (($ <glil-asm> nargs nrest nlocs nexts body)
  55      (let* ((venv (make-venv e nexts #f))
  56             (body (map (lambda (x) (preprocess x venv)) body)))
  57        (make-<vm-asm> venv x body)))
  58     (($ <glil-external> op depth index)
  59      (do ((d depth (1- d))
  60           (e e (venv-parent e)))
  61          ((= d 0))
  62        (set-venv-closure?! e #t))
  63      x)
  64     (else x)))
  65
  66 \f
  67 ;;;
  68 ;;; Stage 2: Bytecode generation
  69 ;;;
  70
  71 (define (codegen glil toplevel)
  72   (match glil
  73     (($ <vm-asm> venv ($ <glil-asm> nargs nrest nlocs nexts _) body)
  74      (let ((stack '())
  75            (label-alist '())
  76            (object-alist '())
  77            (nvars (+ nargs nlocs -1)))
  78        (define (current-address) (length stack))
  79        (define (push-code! code)
  80          (set! stack (optimizing-push code stack)))
  81        (define (object-index obj)
  82          (cond ((assq-ref object-alist obj))
  83                (else (let ((index (length object-alist)))
  84                        (set! object-alist (acons obj index object-alist))
  85                        index))))
  86        (define (label-ref key)
  87          (assq-ref label-alist key))
  88        (define (label-set key pos)
  89          (set! label-alist (assq-set! label-alist key pos)))
  90        (define (generate-code x)
  91          (match x
  92            (($ <vm-asm> env)
  93             (push-code! `(object-ref ,(object-index (codegen x #f))))
  94             (if (venv-closure? env) (push-code! `(make-closure))))
  95
  96            (($ <glil-void>)
  97             (push-code! `(void)))
  98
  99            (($ <glil-const> x)
 100             (if toplevel
 101                 (for-each push-code! (object->dump-code x))
 102                 (cond ((object->code x) => push-code!)
 103                       (else (push-code! `(object-ref ,(object-index x)))))))
 104
 105            (($ <glil-argument> op index)
 106             (push-code! (list (symbol-append 'local- op)
 107                               (- nvars index))))
 108
 109            (($ <glil-local> op index)
 110             (push-code! (list (symbol-append 'local- op)
 111                               (- nvars (+ nargs index)))))
 112
 113            (($ <glil-external> op depth index)
 114             (do ((e venv (venv-parent e))
 115                  (d depth (1- d))
 116                  (i 0 (+ i (venv-nexts e))))
 117                 ((= d 0)
 118                  (push-code! (list (symbol-append 'external- op)
 119                                    (+ index i))))))
 120
 121            (($ <glil-module> op module name)
 122             (let ((mod (make-vmod module)))
 123               (if toplevel
 124                   (begin
 125                     ;; (push-code! `(load-module ,module))
 126                     (push-code! `(load-symbol ,name))
 127                     (push-code! `(link/current-module)))
 128                   (let ((vlink (make-vlink mod name)))
 129                     (push-code! `(object-ref ,(object-index vlink)))))
 130               (push-code! (list (symbol-append 'variable- op)))))
 131
 132            (($ <glil-label> label)
 133             (label-set label (current-address)))
 134
 135            (($ <glil-branch> inst label)
 136             (let ((setter (lambda (addr) (- (label-ref label) (1+ addr)))))
 137               (push-code! (list inst setter))))
 138
 139            (($ <glil-call> inst n)
 140             (push-code! (list inst n)))
 141
 142            (($ <glil-inst> inst)
 143             (if (instruction? inst)
 144                 (push-code! (list inst))
 145                 (error "Unknown instruction:" inst)))))
 146        ;;
 147        ;; main
 148        (if (> nexts 0) (push-code! `(external ,nexts)))
 149        (for-each generate-code body)
 150        (let ((bytes (code->bytes
 151                      (map/index (lambda (v n) (if (procedure? v) (v n) v))
 152                                 (reverse! stack))))
 153              (objs (map car (reverse! object-alist))))
 154          (make-bytespec nargs nrest nlocs bytes objs))))))
 155
 156 (define (map/index f l)
 157   (do ((n 0 (1+ n))
 158        (l l (cdr l))
 159        (r '() (cons (f (car l) n) r)))
 160       ((null? l) (reverse! r))))
 161
 162 ;; Optimization
 163
 164 (define *optimize-table*
 165   '((not       (not       . not-not)
 166                (eq?       . not-eq?)
 167                (null?     . not-null?)
 168                (not-not   . not)
 169                (not-eq?   . eq?)
 170                (not-null? . null?))
 171     (br-if     (not       . br-if-not)
 172                (eq?       . br-if-eq)
 173                (null?     . br-if-null)
 174                (not-not   . br-if)
 175                (not-eq?   . br-if-not-eq)
 176                (not-null? . br-if-not-null))
 177     (br-if-not (not       . br-if)
 178                (eq?       . br-if-not-eq)
 179                (null?     . br-if-not-null)
 180                (not-not   . br-if-not)
 181                (not-eq?   . br-if-eq)
 182                (not-null? . br-if-null))))
 183
 184 (define (optimizing-push code stack)
 185   (let ((alist (assq-ref *optimize-table* (car code))))
 186     (cond ((and alist (pair? stack) (assq-ref alist (car stack))) =>
 187            (lambda (inst) (append! (reverse! (cons inst (cdr code)))
 188                                    (cdr stack))))
 189           (else (append! (reverse! (code-finalize code)) stack)))))
 190
 191 \f
 192 ;;;
 193 ;;; Stage3: Dumpcode generation
 194 ;;;
 195
 196 (define (dump bytespec)
 197   (let* ((table (build-object-table bytespec))
 198          (bytes (bytespec->bytecode bytespec table '(return))))
 199     (if (null? table)
 200         bytes
 201         (let ((spec (make-bytespec 0 0 (length table) bytes '())))
 202           (bytespec->bytecode spec '() '(tail-call 0))))))
 203
 204 (define (bytespec->bytecode bytespec object-table last-code)
 205   (let ((stack '()))
 206     (define (push-code! x)
 207       (set! stack (cons x stack)))
 208     (define (object-index x)
 209       (cond ((object-find object-table x) => cdr)
 210             (else #f)))
 211     (define (dump-table-object! obj+index)
 212       (let dump! ((x (car obj+index)))
 213         (cond
 214          ((vlink? x)
 215           ;; (push-code! `(local-ref ,(object-index (vlink-module x))))
 216           (push-code! `(load-symbol ,(vlink-name x)))
 217           (push-code! `(link/current-module)))
 218          ((vmod? x)
 219           (push-code! `(load-module ,(vmod-id x))))
 220          (else
 221           (for-each push-code! (object->dump-code x)))))
 222       (push-code! `(local-set ,(cdr obj+index))))
 223     (define (dump-object! x)
 224       (let dump! ((x x))
 225         (cond
 226          ((bytespec? x) (dump-bytecode! x))
 227          ((object-index x) => (lambda (i) (push-code! `(local-ref ,i))))
 228          (else
 229           (error "Cannot dump:" x)))))
 230     (define (dump-bytecode! spec)
 231       (let ((nargs (bytespec-nargs spec))
 232             (nrest (bytespec-nrest spec))
 233             (nlocs (bytespec-nlocs spec))
 234             (objs  (bytespec-objs spec)))
 235         (if (and (null? objs) (< nargs 4) (< nlocs 16))
 236             ;; zero-object encoding
 237             (push-code! (object->code (+ (* nargs 32) (* nrest 16) nlocs)))
 238             (begin
 239               ;; dump parameters
 240               (push-code! (object->code nargs))
 241               (push-code! (object->code nrest))
 242               (push-code! (object->code nlocs))
 243               ;; dump object table
 244               (cond ((null? objs) (push-code! (object->code #f)))
 245                     (else
 246                      (push-code! `(mark))
 247                      (for-each dump-object! objs)
 248                      (push-code! `(vector))))))
 249         ;; dump bytecode
 250         (push-code! `(load-program ,(bytespec-bytes spec)))))
 251     ;;
 252     ;; main
 253     (for-each dump-table-object! object-table)
 254     (dump-bytecode! bytespec)
 255     (push-code! last-code)
 256     (code->bytes (apply append! (map code-finalize (reverse! stack))))))
 257
 258 ;; object table
 259
 260 (define (object-find table x)
 261   ((if (or (vlink? x) (vmod? x)) assoc assq) x table))
 262
 263 (define (build-object-table bytespec)
 264   (let ((table '()) (index 0))
 265     (define (insert! x)
 266       (if (vlink? x) (begin (insert! (vlink-module x))))
 267       (if (not (object-find table x))
 268           (begin
 269             (set! table (acons x index table))
 270             (set! index (1+ index)))))
 271     (let loop ((spec bytespec))
 272       (for-each (lambda (x)
 273                   (if (bytespec? x) (loop x) (insert! x)))
 274                 (bytespec-objs spec)))
 275     (reverse! table)))
 276
 277 ;; code generation
 278
 279 (define (code-finalize code)
 280   (match code
 281     ((inst (? symbol? s))
 282      (let ((str (symbol->string s)))
 283        `(,inst ,(string-length str) ,str)))
 284     ((inst (? string? s))
 285      `(,inst ,(string-length s) ,s))
 286     (else (code-pack code))))
 287
 288 (define (integer->string n) (make-string 1 (integer->char n)))
 289
 290 (define (length->string len)
 291   (define C integer->char)
 292   (list->string
 293    (cond ((< len 254) (list (C len)))
 294          ((< len 65536)
 295           (list (C 254) (C (quotient len 256)) (C (modulo len 256))))
 296          ((< len most-positive-fixnum)
 297           (list (C 255)
 298                 (C (quotient len (* 256 256 256)))
 299                 (C (modulo (quotient len (* 256 256)) 256))
 300                 (C (modulo (quotient len 256) 256))
 301                 (C (modulo len 256))))
 302          (else (error "Too long" len)))))
 303
 304 (define (code->bytes code)
 305   (let* ((code (list->vector code))
 306          (size (vector-length code)))
 307     (let loop ((i 0))
 308       (if (>= i size)
 309           (apply string-append (vector->list code))
 310           (let ((inst (vector-ref code i)))
 311             (if (not (instruction? inst))
 312                 (error "Unknown instruction:" inst))
 313             (vector-set! code i (integer->string (instruction->opcode inst)))
 314             (let ((bytes (instruction-length inst)))
 315               (cond ((< bytes 0)
 316                      (vector-set! code i
 317                                   (integer->string (instruction->opcode inst)))
 318                      (vector-set! code (+ i 1)
 319                                   (length->string (vector-ref code (1+ i))))
 320                      (loop (+ i 3)))
 321                     ((= bytes 0) (loop (+ i 1)))
 322                     (else
 323                      (let ((end (+ i 1 bytes)))
 324                        (do ((j (+ i 1) (1+ j)))
 325                            ((= j end) (loop end))
 326                          (vector-set! code j (integer->string
 327                                               (vector-ref code j)))))))))))))