Commit | Line | Data |
---|---|---|
f1d7723b AW |
1 | ;;; Guile Virtual Machine Assembly |
2 | ||
b912a1cd | 3 | ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
f1d7723b | 4 | |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library 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 GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
f1d7723b AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language assembly) | |
782a82ee | 22 | #:use-module (rnrs bytevector) |
f1d7723b AW |
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 |
e5dc27b8 | 27 | addr+ align-program align-code align-block |
4b318482 AW |
28 | assembly-pack assembly-unpack |
29 | object->assembly assembly->object)) | |
53e28ed9 | 30 | |
56164a5a AW |
31 | ;; len, metalen |
32 | (define *program-header-len* (+ 4 4)) | |
f1d7723b | 33 | |
4b318482 AW |
34 | ;; lengths are encoded in 3 bytes |
35 | (define *len-len* 3) | |
36 | ||
9c44cd45 | 37 | |
4b318482 AW |
38 | (define (byte-length assembly) |
39 | (pmatch assembly | |
f1d7723b AW |
40 | (,label (guard (not (pair? label))) |
41 | 0) | |
f1d7723b | 42 | ((load-number ,str) |
4b318482 | 43 | (+ 1 *len-len* (string-length str))) |
f1d7723b | 44 | ((load-string ,str) |
94ff26b9 AW |
45 | (+ 1 *len-len* (string-length str))) |
46 | ((load-wide-string ,str) | |
47 | (+ 1 *len-len* (* 4 (string-length str)))) | |
f1d7723b | 48 | ((load-symbol ,str) |
94ff26b9 | 49 | (+ 1 *len-len* (string-length str))) |
782a82ee AW |
50 | ((load-array ,bv) |
51 | (+ 1 *len-len* (bytevector-length bv))) | |
56164a5a | 52 | ((load-program ,labels ,len ,meta . ,code) |
1f1ec13b | 53 | (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0))) |
f1d7723b | 54 | ((,inst . _) (guard (>= (instruction-length inst) 0)) |
4b318482 AW |
55 | (+ 1 (instruction-length inst))) |
56 | (else (error "unknown instruction" assembly)))) | |
53e28ed9 | 57 | |
2cf1705c AW |
58 | |
59 | (define *program-alignment* 8) | |
60 | ||
e5dc27b8 AW |
61 | (define *block-alignment* 8) |
62 | ||
2cf1705c AW |
63 | (define (addr+ addr code) |
64 | (fold (lambda (x len) (+ (byte-length x) len)) | |
65 | addr | |
66 | code)) | |
67 | ||
e5dc27b8 AW |
68 | (define (code-alignment addr alignment header-len) |
69 | (make-list (modulo (- alignment | |
70 | (modulo (+ addr header-len) alignment)) | |
71 | alignment) | |
72 | '(nop))) | |
73 | ||
74 | (define (align-block addr) | |
97fcf583 | 75 | '()) |
782a82ee AW |
76 | |
77 | (define (align-code code addr alignment header-len) | |
e5dc27b8 | 78 | `(,@(code-alignment addr alignment header-len) |
782a82ee AW |
79 | ,code)) |
80 | ||
81 | (define (align-program prog addr) | |
82 | (align-code prog addr *program-alignment* 1)) | |
2cf1705c | 83 | |
53e28ed9 AW |
84 | ;;; |
85 | ;;; Code compress/decompression | |
86 | ;;; | |
87 | ||
88 | (define *abbreviations* | |
89 | '(((make-int8 0) . (make-int8:0)) | |
90 | ((make-int8 1) . (make-int8:1)))) | |
91 | ||
92 | (define *expansions* | |
93 | (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*)) | |
94 | ||
4b318482 | 95 | (define (assembly-pack code) |
194566b0 | 96 | (or (assoc-ref *abbreviations* code) |
53e28ed9 AW |
97 | code)) |
98 | ||
4b318482 | 99 | (define (assembly-unpack code) |
194566b0 | 100 | (or (assoc-ref *expansions* code) |
53e28ed9 AW |
101 | code)) |
102 | ||
103 | \f | |
104 | ;;; | |
105 | ;;; Encoder/decoder | |
106 | ;;; | |
107 | ||
4b318482 | 108 | (define (object->assembly x) |
53e28ed9 AW |
109 | (cond ((eq? x #t) `(make-true)) |
110 | ((eq? x #f) `(make-false)) | |
111 | ((null? x) `(make-eol)) | |
112 | ((and (integer? x) (exact? x)) | |
113 | (cond ((and (<= -128 x) (< x 128)) | |
28b119ee | 114 | (assembly-pack `(make-int8 ,(modulo x 256)))) |
53e28ed9 AW |
115 | ((and (<= -32768 x) (< x 32768)) |
116 | (let ((n (if (< x 0) (+ x 65536) x))) | |
117 | `(make-int16 ,(quotient n 256) ,(modulo n 256)))) | |
586cfdec AW |
118 | ((and (<= 0 x #xffffffffffffffff)) |
119 | `(make-uint64 ,@(bytevector->u8-list | |
120 | (let ((bv (make-bytevector 8))) | |
121 | (bytevector-u64-set! bv 0 x (endianness big)) | |
122 | bv)))) | |
123 | ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff)) | |
124 | `(make-int64 ,@(bytevector->u8-list | |
125 | (let ((bv (make-bytevector 8))) | |
126 | (bytevector-s64-set! bv 0 x (endianness big)) | |
127 | bv)))) | |
53e28ed9 | 128 | (else #f))) |
904a78f1 MG |
129 | ((char? x) |
130 | (cond ((<= (char->integer x) #xff) | |
131 | `(make-char8 ,(char->integer x))) | |
132 | (else | |
133 | `(make-char32 ,(char->integer x))))) | |
53e28ed9 AW |
134 | (else #f))) |
135 | ||
4b318482 | 136 | (define (assembly->object code) |
53e28ed9 AW |
137 | (pmatch code |
138 | ((make-true) #t) | |
139 | ((make-false) #f) ;; FIXME: Same as the `else' case! | |
140 | ((make-eol) '()) | |
141 | ((make-int8 ,n) | |
142 | (if (< n 128) n (- n 256))) | |
143 | ((make-int16 ,n1 ,n2) | |
144 | (let ((n (+ (* n1 256) n2))) | |
145 | (if (< n 32768) n (- n 65536)))) | |
586cfdec AW |
146 | ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8) |
147 | (bytevector-u64-ref | |
148 | (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8)) | |
149 | 0 | |
150 | (endianness big))) | |
151 | ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8) | |
152 | (bytevector-s64-ref | |
153 | (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8)) | |
154 | 0 | |
155 | (endianness big))) | |
53e28ed9 AW |
156 | ((make-char8 ,n) |
157 | (integer->char n)) | |
904a78f1 MG |
158 | ((make-char32 ,n1 ,n2 ,n3 ,n4) |
159 | (integer->char (+ (* n1 #x1000000) | |
160 | (* n2 #x10000) | |
161 | (* n3 #x100) | |
162 | n4))) | |
53e28ed9 AW |
163 | ((load-string ,s) s) |
164 | ((load-symbol ,s) (string->symbol s)) | |
53e28ed9 | 165 | (else #f))) |