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