summaryrefslogtreecommitdiff
path: root/module/language/assembly.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/assembly.scm')
-rw-r--r--module/language/assembly.scm105
1 files changed, 70 insertions, 35 deletions
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 28dde1e1a..683da6cc1 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -2,57 +2,54 @@
;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (language assembly)
+ #:use-module (rnrs bytevector)
#:use-module (system base pmatch)
#:use-module (system vm instruction)
#:use-module ((srfi srfi-1) #:select (fold))
#:export (byte-length
- addr+ align-program
+ addr+ align-program align-code align-block
assembly-pack assembly-unpack
object->assembly assembly->object))
-;; nargs, nrest, nlocs, nexts, len, metalen
-(define *program-header-len* (+ 1 1 1 1 4 4))
+;; nargs, nrest, nlocs, len, metalen, padding
+(define *program-header-len* (+ 1 1 2 4 4 4))
;; lengths are encoded in 3 bytes
(define *len-len* 3)
+
(define (byte-length assembly)
(pmatch assembly
(,label (guard (not (pair? label)))
0)
- ((load-unsigned-integer ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-integer ,str)
- (+ 1 *len-len* (string-length str)))
((load-number ,str)
(+ 1 *len-len* (string-length str)))
((load-string ,str)
(+ 1 *len-len* (string-length str)))
+ ((load-wide-string ,str)
+ (+ 1 *len-len* (* 4 (string-length str))))
((load-symbol ,str)
(+ 1 *len-len* (string-length str)))
- ((load-keyword ,str)
- (+ 1 *len-len* (string-length str)))
- ((define ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+ ((load-array ,bv)
+ (+ 1 *len-len* (bytevector-length bv)))
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
@@ -61,18 +58,28 @@
(define *program-alignment* 8)
+(define *block-alignment* 8)
+
(define (addr+ addr code)
(fold (lambda (x len) (+ (byte-length x) len))
addr
code))
+(define (code-alignment addr alignment header-len)
+ (make-list (modulo (- alignment
+ (modulo (+ addr header-len) alignment))
+ alignment)
+ '(nop)))
+
+(define (align-block addr)
+ (code-alignment addr *block-alignment* 0))
+
+(define (align-code code addr alignment header-len)
+ `(,@(code-alignment addr alignment header-len)
+ ,code))
+
(define (align-program prog addr)
- `(,@(make-list (modulo (- *program-alignment*
- (modulo (1+ addr) *program-alignment*))
- ;; plus the one for the load-program inst itself
- *program-alignment*)
- '(nop))
- ,prog))
+ (align-code prog addr *program-alignment* 1))
;;;
;;; Code compress/decompression
@@ -104,12 +111,26 @@
((null? x) `(make-eol))
((and (integer? x) (exact? x))
(cond ((and (<= -128 x) (< x 128))
- `(make-int8 ,(modulo x 256)))
+ (assembly-pack `(make-int8 ,(modulo x 256))))
((and (<= -32768 x) (< x 32768))
(let ((n (if (< x 0) (+ x 65536) x)))
`(make-int16 ,(quotient n 256) ,(modulo n 256))))
+ ((and (<= 0 x #xffffffffffffffff))
+ `(make-uint64 ,@(bytevector->u8-list
+ (let ((bv (make-bytevector 8)))
+ (bytevector-u64-set! bv 0 x (endianness big))
+ bv))))
+ ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff))
+ `(make-int64 ,@(bytevector->u8-list
+ (let ((bv (make-bytevector 8)))
+ (bytevector-s64-set! bv 0 x (endianness big))
+ bv))))
(else #f)))
- ((char? x) `(make-char8 ,(char->integer x)))
+ ((char? x)
+ (cond ((<= (char->integer x) #xff)
+ `(make-char8 ,(char->integer x)))
+ (else
+ `(make-char32 ,(char->integer x)))))
(else #f)))
(define (assembly->object code)
@@ -122,9 +143,23 @@
((make-int16 ,n1 ,n2)
(let ((n (+ (* n1 256) n2)))
(if (< n 32768) n (- n 65536))))
+ ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
+ (bytevector-u64-ref
+ (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
+ 0
+ (endianness big)))
+ ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
+ (bytevector-s64-ref
+ (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
+ 0
+ (endianness big)))
((make-char8 ,n)
(integer->char n))
+ ((make-char32 ,n1 ,n2 ,n3 ,n4)
+ (integer->char (+ (* n1 #x1000000)
+ (* n2 #x10000)
+ (* n3 #x100)
+ n4)))
((load-string ,s) s)
((load-symbol ,s) (string->symbol s))
- ((load-keyword ,s) (symbol->keyword (string->symbol s)))
(else #f)))