Commit | Line | Data |
---|---|---|
f1d7723b AW |
1 | ;;; Guile Virtual Machine Assembly |
2 | ||
b912a1cd | 3 | ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
f1d7723b AW |
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 assembly) | |
23 | #:use-module (system base pmatch) | |
24 | #:use-module (system vm instruction) | |
2cf1705c | 25 | #:use-module ((srfi srfi-1) #:select (fold)) |
4b318482 | 26 | #:export (byte-length |
2cf1705c | 27 | addr+ align-program |
4b318482 AW |
28 | assembly-pack assembly-unpack |
29 | object->assembly assembly->object)) | |
53e28ed9 | 30 | |
9aeaabdc AW |
31 | ;; nargs, nrest, nlocs, nexts, len, metalen |
32 | (define *program-header-len* (+ 1 1 1 1 4 4)) | |
f1d7723b | 33 | |
4b318482 AW |
34 | ;; lengths are encoded in 3 bytes |
35 | (define *len-len* 3) | |
36 | ||
37 | (define (byte-length assembly) | |
38 | (pmatch assembly | |
f1d7723b AW |
39 | (,label (guard (not (pair? label))) |
40 | 0) | |
b912a1cd LC |
41 | ((load-unsigned-integer ,str) |
42 | (+ 1 *len-len* (string-length str))) | |
f1d7723b | 43 | ((load-integer ,str) |
4b318482 | 44 | (+ 1 *len-len* (string-length str))) |
f1d7723b | 45 | ((load-number ,str) |
4b318482 | 46 | (+ 1 *len-len* (string-length str))) |
f1d7723b | 47 | ((load-string ,str) |
4b318482 | 48 | (+ 1 *len-len* (string-length str))) |
f1d7723b | 49 | ((load-symbol ,str) |
4b318482 | 50 | (+ 1 *len-len* (string-length str))) |
f1d7723b | 51 | ((load-keyword ,str) |
4b318482 | 52 | (+ 1 *len-len* (string-length str))) |
f1d7723b | 53 | ((define ,str) |
4b318482 | 54 | (+ 1 *len-len* (string-length str))) |
1f1ec13b AW |
55 | ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code) |
56 | (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0))) | |
f1d7723b | 57 | ((,inst . _) (guard (>= (instruction-length inst) 0)) |
4b318482 AW |
58 | (+ 1 (instruction-length inst))) |
59 | (else (error "unknown instruction" assembly)))) | |
53e28ed9 | 60 | |
2cf1705c AW |
61 | |
62 | (define *program-alignment* 8) | |
63 | ||
64 | (define (addr+ addr code) | |
65 | (fold (lambda (x len) (+ (byte-length x) len)) | |
66 | addr | |
67 | code)) | |
68 | ||
69 | (define (align-program prog addr) | |
70 | `(,@(make-list (modulo (- *program-alignment* | |
1005628a AW |
71 | (modulo (1+ addr) *program-alignment*)) |
72 | ;; plus the one for the load-program inst itself | |
2cf1705c AW |
73 | *program-alignment*) |
74 | '(nop)) | |
75 | ,prog)) | |
76 | ||
53e28ed9 AW |
77 | ;;; |
78 | ;;; Code compress/decompression | |
79 | ;;; | |
80 | ||
81 | (define *abbreviations* | |
82 | '(((make-int8 0) . (make-int8:0)) | |
83 | ((make-int8 1) . (make-int8:1)))) | |
84 | ||
85 | (define *expansions* | |
86 | (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*)) | |
87 | ||
4b318482 | 88 | (define (assembly-pack code) |
194566b0 | 89 | (or (assoc-ref *abbreviations* code) |
53e28ed9 AW |
90 | code)) |
91 | ||
4b318482 | 92 | (define (assembly-unpack code) |
194566b0 | 93 | (or (assoc-ref *expansions* code) |
53e28ed9 AW |
94 | code)) |
95 | ||
96 | \f | |
97 | ;;; | |
98 | ;;; Encoder/decoder | |
99 | ;;; | |
100 | ||
4b318482 | 101 | (define (object->assembly x) |
53e28ed9 AW |
102 | (cond ((eq? x #t) `(make-true)) |
103 | ((eq? x #f) `(make-false)) | |
104 | ((null? x) `(make-eol)) | |
105 | ((and (integer? x) (exact? x)) | |
106 | (cond ((and (<= -128 x) (< x 128)) | |
107 | `(make-int8 ,(modulo x 256))) | |
108 | ((and (<= -32768 x) (< x 32768)) | |
109 | (let ((n (if (< x 0) (+ x 65536) x))) | |
110 | `(make-int16 ,(quotient n 256) ,(modulo n 256)))) | |
111 | (else #f))) | |
112 | ((char? x) `(make-char8 ,(char->integer x))) | |
113 | (else #f))) | |
114 | ||
4b318482 | 115 | (define (assembly->object code) |
53e28ed9 AW |
116 | (pmatch code |
117 | ((make-true) #t) | |
118 | ((make-false) #f) ;; FIXME: Same as the `else' case! | |
119 | ((make-eol) '()) | |
120 | ((make-int8 ,n) | |
121 | (if (< n 128) n (- n 256))) | |
122 | ((make-int16 ,n1 ,n2) | |
123 | (let ((n (+ (* n1 256) n2))) | |
124 | (if (< n 32768) n (- n 65536)))) | |
125 | ((make-char8 ,n) | |
126 | (integer->char n)) | |
127 | ((load-string ,s) s) | |
128 | ((load-symbol ,s) (string->symbol s)) | |
129 | ((load-keyword ,s) (symbol->keyword (string->symbol s))) | |
130 | (else #f))) |