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