module/language/assembly/compile-bytecode.scm

   1 ;;; Guile VM assembler
   2
   3 ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
   4
   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
  18
  19 ;;; Code:
  20
  21 (define-module (language assembly compile-bytecode)
  22   #:use-module (system base pmatch)
  23   #:use-module (language assembly)
  24   #:use-module (system vm instruction)
  25   #:use-module (srfi srfi-4)
  26   #:use-module (rnrs bytevector)
  27   #:use-module ((srfi srfi-1) #:select (fold))
  28   #:use-module ((system vm objcode) #:select (byte-order))
  29   #:export (compile-bytecode write-bytecode))
  30
  31 (define (compile-bytecode assembly env . opts)
  32   (pmatch assembly
  33     ((load-program . _)
  34      ;; the 1- and -1 are so that we drop the load-program byte
  35      (letrec ((v (make-u8vector (1- (byte-length assembly))))
  36               (i -1)
  37               (write-byte (lambda (b)
  38                             (if (>= i 0) (u8vector-set! v i b))
  39                             (set! i (1+ i))))
  40               (get-addr (lambda () i)))
  41        (write-bytecode assembly write-byte get-addr '())
  42        (if (= i (u8vector-length v))
  43            (values v env env)
  44            (error "incorrect length in assembly" i (u8vector-length v)))))
  45     (else (error "bad assembly" assembly))))
  46
  47 (define (write-bytecode asm write-byte get-addr labels)
  48   (define (write-char c)
  49     (write-byte (char->integer c)))
  50   (define (write-string s)
  51     (string-for-each write-char s))
  52   (define (write-uint16-be x)
  53     (write-byte (logand (ash x -8) 255))
  54     (write-byte (logand x 255)))
  55   (define (write-uint16-le x)
  56     (write-byte (logand x 255))
  57     (write-byte (logand (ash x -8) 255)))
  58   (define (write-uint32-be x)
  59     (write-byte (logand (ash x -24) 255))
  60     (write-byte (logand (ash x -16) 255))
  61     (write-byte (logand (ash x -8) 255))
  62     (write-byte (logand x 255)))
  63   (define (write-uint32-le x)
  64     (write-byte (logand x 255))
  65     (write-byte (logand (ash x -8) 255))
  66     (write-byte (logand (ash x -16) 255))
  67     (write-byte (logand (ash x -24) 255)))
  68   (define (write-uint32 x)
  69     (case byte-order
  70       ((1234) (write-uint32-le x))
  71       ((4321) (write-uint32-be x))
  72       (else (error "unknown endianness" byte-order))))
  73   (define (write-wide-string s)
  74     (write-loader-len (* 4 (string-length s)))
  75     (string-for-each (lambda (c) (write-uint32 (char->integer c))) s))
  76   (define (write-loader-len len)
  77     (write-byte (ash len -16))
  78     (write-byte (logand (ash len -8) 255))
  79     (write-byte (logand len 255)))
  80   (define (write-loader str)
  81     (write-loader-len (string-length str))
  82     (write-string str))
  83   (define (write-sized-loader str)
  84     (let ((len (string-length str))
  85           (wid (string-bytes-per-char str)))
  86       (write-loader-len len)
  87       (write-byte wid)
  88       (if (= wid 4)
  89           (write-wide-string str)
  90           (write-string str))))
  91   (define (write-bytevector bv)
  92     (write-loader-len (bytevector-length bv))
  93     ;; Ew!
  94     (for-each write-byte (bytevector->u8-list bv)))
  95   (define (write-break label)
  96     (let ((offset (- (assq-ref labels label)
  97                      (logand (+ (get-addr) 2) (lognot #x7)))))
  98       (cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset))
  99             ((>= offset (ash 1 18)) (error "jump too far forward" offset))
 100             ((< offset (- (ash 1 18))) (error "jump too far backwards" offset))
 101             (else (write-uint16-be (ash offset -3))))))
 102
 103   (let ((inst (car asm))
 104         (args (cdr asm))
 105         (write-uint16 (case byte-order
 106                         ((1234) write-uint16-le)
 107                         ((4321) write-uint16-be)
 108                         (else (error "unknown endianness" byte-order)))))
 109     (let ((opcode (instruction->opcode inst))
 110           (len (instruction-length inst)))
 111       (write-byte opcode)
 112       (pmatch asm
 113         ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
 114          (write-byte nargs)
 115          (write-byte nrest)
 116          (write-uint16 nlocs)
 117          (write-uint32 length)
 118          (write-uint32 (if meta (1- (byte-length meta)) 0))
 119          (write-uint32 0) ; padding
 120          (letrec ((i 0)
 121                   (write (lambda (x) (set! i (1+ i)) (write-byte x)))
 122                   (get-addr (lambda () i)))
 123            (for-each (lambda (asm)
 124                        (write-bytecode asm write get-addr labels))
 125                      code))
 126          (if meta
 127              ;; don't write the load-program byte for metadata
 128              (letrec ((i -1)
 129                       (write (lambda (x)
 130                                (set! i (1+ i))
 131                                (if (> i 0) (write-byte x))))
 132                       (get-addr (lambda () i)))
 133                ;; META's bytecode meets the alignment requirements of
 134                ;; `scm_objcode', thanks to the alignment computed in
 135                ;; `(language assembly)'.
 136                (write-bytecode meta write get-addr '()))))
 137         ((make-char32 ,x) (write-uint32-be x))
 138         ((load-number ,str) (write-loader str))
 139         ((load-string ,str) (write-loader str))
 140         ((load-wide-string ,str) (write-wide-string str))
 141         ((load-symbol ,str) (write-loader str))
 142         ((load-array ,bv) (write-bytevector bv))
 143         ((br ,l) (write-break l))
 144         ((br-if ,l) (write-break l))
 145         ((br-if-not ,l) (write-break l))
 146         ((br-if-eq ,l) (write-break l))
 147         ((br-if-not-eq ,l) (write-break l))
 148         ((br-if-null ,l) (write-break l))
 149         ((br-if-not-null ,l) (write-break l))
 150         ((mv-call ,n ,l) (write-byte n) (write-break l))
 151         (else
 152          (cond
 153           ((< (instruction-length inst) 0)
 154            (error "unhanded variable-length instruction" asm))
 155           ((not (= (length args) len))
 156            (error "bad number of args to instruction" asm len))
 157           (else
 158            (for-each write-byte args))))))))