Commit | Line | Data |
---|---|---|
f1d7723b AW |
1 | ;;; Guile Virtual Machine Assembly |
2 | ||
81f52909 | 3 | ;; Copyright (C) 2001, 2009, 2010, 2011 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) | |
07d22c02 | 22 | #:use-module (rnrs bytevectors) |
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 | |
81f52909 AW |
40 | ((,inst . _) (guard (>= (instruction-length inst) 0)) |
41 | (+ 1 (instruction-length inst))) | |
f1d7723b | 42 | ((load-number ,str) |
4b318482 | 43 | (+ 1 *len-len* (string-length str))) |
f1d7723b | 44 | ((load-string ,str) |
4b318482 | 45 | (+ 1 *len-len* (string-length str))) |
94ff26b9 AW |
46 | ((load-wide-string ,str) |
47 | (+ 1 *len-len* (* 4 (string-length str)))) | |
f1d7723b | 48 | ((load-symbol ,str) |
4b318482 | 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))) |
81f52909 AW |
54 | (,label (guard (not (pair? label))) |
55 | 0) | |
4b318482 | 56 | (else (error "unknown instruction" assembly)))) |
53e28ed9 | 57 | |
2cf1705c AW |
58 | |
59 | (define *program-alignment* 8) | |
60 | ||
61 | (define (addr+ addr code) | |
62 | (fold (lambda (x len) (+ (byte-length x) len)) | |
63 | addr | |
64 | code)) | |
65 | ||
e5dc27b8 AW |
66 | (define (code-alignment addr alignment header-len) |
67 | (make-list (modulo (- alignment | |
68 | (modulo (+ addr header-len) alignment)) | |
69 | alignment) | |
70 | '(nop))) | |
71 | ||
72 | (define (align-block addr) | |
97fcf583 | 73 | '()) |
782a82ee AW |
74 | |
75 | (define (align-code code addr alignment header-len) | |
e5dc27b8 | 76 | `(,@(code-alignment addr alignment header-len) |
782a82ee AW |
77 | ,code)) |
78 | ||
79 | (define (align-program prog addr) | |
80 | (align-code prog addr *program-alignment* 1)) | |
2cf1705c | 81 | |
53e28ed9 AW |
82 | ;;; |
83 | ;;; Code compress/decompression | |
84 | ;;; | |
85 | ||
86 | (define *abbreviations* | |
87 | '(((make-int8 0) . (make-int8:0)) | |
88 | ((make-int8 1) . (make-int8:1)))) | |
89 | ||
90 | (define *expansions* | |
91 | (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*)) | |
92 | ||
4b318482 | 93 | (define (assembly-pack code) |
194566b0 | 94 | (or (assoc-ref *abbreviations* code) |
53e28ed9 AW |
95 | code)) |
96 | ||
4b318482 | 97 | (define (assembly-unpack code) |
194566b0 | 98 | (or (assoc-ref *expansions* code) |
53e28ed9 AW |
99 | code)) |
100 | ||
101 | \f | |
102 | ;;; | |
103 | ;;; Encoder/decoder | |
104 | ;;; | |
105 | ||
4b318482 | 106 | (define (object->assembly x) |
53e28ed9 AW |
107 | (cond ((eq? x #t) `(make-true)) |
108 | ((eq? x #f) `(make-false)) | |
54e53aa4 | 109 | ((eq? x #nil) `(make-nil)) |
53e28ed9 AW |
110 | ((null? x) `(make-eol)) |
111 | ((and (integer? x) (exact? x)) | |
112 | (cond ((and (<= -128 x) (< x 128)) | |
28b119ee | 113 | (assembly-pack `(make-int8 ,(modulo x 256)))) |
53e28ed9 AW |
114 | ((and (<= -32768 x) (< x 32768)) |
115 | (let ((n (if (< x 0) (+ x 65536) x))) | |
116 | `(make-int16 ,(quotient n 256) ,(modulo n 256)))) | |
586cfdec AW |
117 | ((and (<= 0 x #xffffffffffffffff)) |
118 | `(make-uint64 ,@(bytevector->u8-list | |
119 | (let ((bv (make-bytevector 8))) | |
120 | (bytevector-u64-set! bv 0 x (endianness big)) | |
121 | bv)))) | |
122 | ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff)) | |
123 | `(make-int64 ,@(bytevector->u8-list | |
124 | (let ((bv (make-bytevector 8))) | |
125 | (bytevector-s64-set! bv 0 x (endianness big)) | |
126 | bv)))) | |
53e28ed9 | 127 | (else #f))) |
904a78f1 MG |
128 | ((char? x) |
129 | (cond ((<= (char->integer x) #xff) | |
130 | `(make-char8 ,(char->integer x))) | |
131 | (else | |
132 | `(make-char32 ,(char->integer x))))) | |
53e28ed9 AW |
133 | (else #f))) |
134 | ||
4b318482 | 135 | (define (assembly->object code) |
53e28ed9 AW |
136 | (pmatch code |
137 | ((make-true) #t) | |
138 | ((make-false) #f) ;; FIXME: Same as the `else' case! | |
54e53aa4 | 139 | ((make-nil) #nil) |
53e28ed9 AW |
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))) |