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 il glil)
  25   :use-module (system vm core)
  26   :use-module (system vm conv)
  27   :use-module (ice-9 match)
  28   :use-module (ice-9 regex)
  29   :use-module (ice-9 common-list)
  30   :export (assemble))
  31
  32 (define (assemble glil env . opts)
  33   (optimizing-dump (codegen (preprocess glil #f) #t)))
  34
  35 \f
  36 ;;;
  37 ;;; Types
  38 ;;;
  39
  40 (define-structure (<vm-asm> venv glil body))
  41 (define-structure (venv parent nexts closure?))
  42 (define-structure (vmod id))
  43 (define-structure (vlink module name))
  44 (define-structure (bytespec nargs nrest nlocs nexts bytes objs))
  45
  46 \f
  47 ;;;
  48 ;;; Stage 1: Preprocess
  49 ;;;
  50
  51 (define (preprocess x e)
  52   (match x
  53     (($ <glil-asm> nargs nrest nlocs nexts body)
  54      (let* ((venv (make-venv e nexts #f))
  55             (body (map (lambda (x) (preprocess x venv)) body)))
  56        (make-<vm-asm> venv x body)))
  57     (($ <glil-external> op depth index)
  58      (do ((d depth (1- d))
  59           (e e (venv-parent e)))
  60          ((= d 0))
  61        (set-venv-closure?! e #t))
  62      x)
  63     (else x)))
  64
  65 \f
  66 ;;;
  67 ;;; Stage 2: Bytecode generation
  68 ;;;
  69
  70 (define (codegen glil toplevel)
  71   (match glil
  72     (($ <vm-asm> venv ($ <glil-asm> nargs nrest nlocs nexts _) body)
  73      (let ((stack '())
  74            (label-alist '())
  75            (object-alist '())
  76            (nvars (+ nargs nlocs -1)))
  77        (define (push-code! code)
  78          (set! stack (optimizing-push code stack)))
  79        (define (push-object! x)
  80          (let ((index (or ((if (vlink? x) assoc-ref assq-ref) object-alist x)
  81                           (let ((index (length object-alist)))
  82                             (set! object-alist (acons x index object-alist))
  83                             index))))
  84            (push-code! `(object-ref ,index))))
  85        (define (label-ref key)
  86          (assq-ref label-alist key))
  87        (define (label-set key)
  88          (let ((addr (apply + (map length stack))))
  89            (set! label-alist (assq-set! label-alist key addr))))
  90        (define (generate-code x)
  91          (match x
  92            (($ <vm-asm> venv)
  93             (let ((spec (codegen x #f)))
  94               (if toplevel
  95                   (dump-object! spec push-code!)
  96                   (push-object! spec)))
  97             (if (venv-closure? venv) (push-code! `(make-closure))))
  98
  99            (($ <glil-void>)
 100             (push-code! `(void)))
 101
 102            (($ <glil-const> x)
 103             (if toplevel
 104                 (dump-object! x push-code!)
 105                 (cond ((object->code x) => push-code!)
 106                       (else (push-object! x)))))
 107
 108            (($ <glil-argument> op index)
 109             (push-code! `(,(symbol-append 'local- op) ,(- nvars index))))
 110
 111            (($ <glil-local> op index)
 112             (push-code! `(,(symbol-append 'local- op)
 113                           ,(- nvars (+ nargs index)))))
 114
 115            (($ <glil-external> op depth index)
 116             (do ((e venv (venv-parent e))
 117                  (d depth (1- d))
 118                  (i 0 (+ i (venv-nexts e))))
 119                 ((= d 0)
 120                  (push-code! `(,(symbol-append 'external- op) ,(+ index i))))))
 121
 122            (($ <glil-module> op module name)
 123             ;; (let ((vlink (make-vlink (make-vmod module) name)))
 124             (let ((vlink (make-vlink #f name)))
 125               (if toplevel
 126                   (dump-object! vlink push-code!)
 127                   (push-object! vlink)))
 128             (push-code! (list (symbol-append 'variable- op))))
 129
 130            (($ <glil-label> label)
 131             (label-set label))
 132
 133            (($ <glil-branch> inst label)
 134             (let ((setter (lambda (addr) (- (label-ref label) addr))))
 135               (push-code! (list inst setter))))
 136
 137            (($ <glil-call> inst nargs)
 138             (if (instruction? inst)
 139                 (let ((pops (instruction-pops inst)))
 140                   (cond ((< pops 0)
 141                          (push-code! (list inst nargs)))
 142                         ((= pops nargs)
 143                          (push-code! (list inst)))
 144                         (else
 145                          (error "Wrong number of arguments:" inst nargs))))
 146                 (error "Unknown instruction:" inst)))))
 147        ;;
 148        ;; main
 149        (for-each generate-code body)
 150        (let ((bytes (apply string-append (stack-finalize (reverse! stack))))
 151              (objs (map car (reverse! object-alist))))
 152          (make-bytespec nargs nrest nlocs nexts bytes objs))))))
 153
 154 (define (stack-finalize stack)
 155   (let loop ((list '()) (stack stack) (addr 0))
 156     (if (null? stack)
 157         (reverse! list)
 158         (let* ((orig (car stack))
 159                (addr (+ addr (length orig)))
 160                (code (if (and (pair? (cdr orig)) (procedure? (cadr orig)))
 161                          `(,(car orig) ,((cadr orig) addr))
 162                          orig)))
 163           (loop (cons (code->bytes code) list) (cdr stack) addr)))))
 164
 165 ;; Optimization
 166
 167 (define *optimize-table*
 168   '((not       (not       . not-not)
 169                (eq?       . not-eq?)
 170                (null?     . not-null?)
 171                (not-not   . not)
 172                (not-eq?   . eq?)
 173                (not-null? . null?))
 174     (br-if     (not       . br-if-not)
 175                (eq?       . br-if-eq)
 176                (null?     . br-if-null)
 177                (not-not   . br-if)
 178                (not-eq?   . br-if-not-eq)
 179                (not-null? . br-if-not-null))
 180     (br-if-not (not       . br-if)
 181                (eq?       . br-if-not-eq)
 182                (null?     . br-if-not-null)
 183                (not-not   . br-if-not)
 184                (not-eq?   . br-if-eq)
 185                (not-null? . br-if-null))))
 186
 187 (define (optimizing-push code stack)
 188   (let ((alist (assq-ref *optimize-table* (car code))))
 189     (cond ((and alist (pair? stack) (assq-ref alist (caar stack))) =>
 190            (lambda (inst) (cons (cons inst (cdr code)) (cdr stack))))
 191           (else (cons (code-pack code) stack)))))
 192
 193 \f
 194 ;;;
 195 ;;; Stage3: Dump optimization
 196 ;;;
 197
 198 (define (optimizing-dump bytespec)
 199   ;; no optimization yet
 200   (bytespec-bytes bytespec))
 201
 202 (define (dump-object! x push-code!)
 203   (let dump! ((x x))
 204     (cond
 205      ((object->code x) => push-code!)
 206      ((bytespec? x)
 207       (let ((nargs (bytespec-nargs x))
 208             (nrest (bytespec-nrest x))
 209             (nlocs (bytespec-nlocs x))
 210             (nexts (bytespec-nexts x))
 211             (bytes (bytespec-bytes x))
 212             (objs  (bytespec-objs x)))
 213         ;; dump parameters
 214         (cond ((and (< nargs 4) (< nlocs 8) (< nexts 4))
 215                ;; 8-bit representation
 216                (let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
 217                  (push-code! `(make-int8 ,x))))
 218               ((and (< nargs 16) (< nlocs 128) (< nexts 16))
 219                ;; 16-bit representation
 220                (let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
 221                  (push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
 222               (else
 223                ;; Other cases
 224                (push-code! (object->code nargs))
 225                (push-code! (object->code nrest))
 226                (push-code! (object->code nlocs))
 227                (push-code! (object->code nexts))
 228                (push-code! (object->code #f))))
 229         ;; dump object table
 230         (cond ((not (null? objs))
 231                (for-each dump! objs)
 232                (push-code! `(vector ,(length objs)))))
 233         ;; dump bytecode
 234         (push-code! `(load-program ,bytes))))
 235      ((vlink? x)
 236       ;; (push-code! `(local-ref ,(object-index (vlink-module x))))
 237       (dump! (vlink-name x))
 238       (push-code! `(link/current-module)))
 239      ;;((vmod? x)
 240      ;;  (push-code! `(load-module ,(vmod-id x))))
 241      ((integer? x)
 242       (let ((str (do ((n x (quotient n 256))
 243                       (l '() (cons (modulo n 256) l)))
 244                      ((= n 0)
 245                       (list->string (map integer->char l))))))
 246         (push-code! `(load-integer ,str))))
 247      ((string? x)
 248       (push-code! `(load-string ,x)))
 249      ((symbol? x)
 250       (push-code! `(load-symbol ,(symbol->string x))))
 251      ((keyword? x)
 252       (push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x)))))
 253      ((list? x)
 254       (for-each dump! x)
 255       (push-code! `(list ,(length x))))
 256      ((pair? x)
 257       (dump! (car x))
 258       (dump! (cdr x))
 259       (push-code! `(cons)))
 260      ((vector? x)
 261       (for-each dump! (vector->list x))
 262       (push-code! `(vector ,(vector-length x))))
 263      (else
 264       (error "Cannot dump:" x)))))
 265
 266 ;;;(define (dump-table-object! obj+index)
 267 ;;;  (let dump! ((x (car obj+index)))
 268 ;;;    (cond
 269 ;;;     (else
 270 ;;;      (for-each push-code! (dump-object! x)))))
 271 ;;;  (push-code! `(local-set ,(cdr obj+index))))