module/language/assembly/compile-bytecode.scm

   1 ;;; Guile VM assembler
   2
   3 ;; Copyright (C) 2001, 2009, 2010 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 (rnrs io ports)
  28   #:use-module ((srfi srfi-1) #:select (fold))
  29   #:use-module ((srfi srfi-26) #:select (cut))
  30   #:use-module ((system vm objcode) #:select (byte-order))
  31   #:export (compile-bytecode write-bytecode))
  32
  33 (define (compile-bytecode assembly env . opts)
  34   (pmatch assembly
  35     ((load-program . _)
  36      (call-with-values open-bytevector-output-port
  37        (lambda (port get-bytevector)
  38          ;; Don't emit the `load-program' byte.
  39          (write-bytecode assembly port '() 0 #f)
  40          (values (get-bytevector) env env))))
  41     (else (error "bad assembly" assembly))))
  42
  43 (define (write-bytecode asm port labels address emit-opcode?)
  44   ;; Write ASM's bytecode to PORT, a (binary) output port.  If EMIT-OPCODE? is
  45   ;; false, don't emit bytecode for the first opcode encountered.  Assume code
  46   ;; starts at ADDRESS (an integer).  LABELS is assumed to be an alist mapping
  47   ;; labels to addresses.
  48   (define write-byte (cut put-u8 port <>))
  49   (define get-addr
  50     (let ((start (port-position port)))
  51       (lambda ()
  52         (+ address (- (port-position port) start)))))
  53   (define (write-char c)
  54     (write-byte (char->integer c)))
  55   (define (write-string s)
  56     (string-for-each write-char s))
  57   (define (write-uint16-be x)
  58     (write-byte (logand (ash x -8) 255))
  59     (write-byte (logand x 255)))
  60   (define (write-uint16-le x)
  61     (write-byte (logand x 255))
  62     (write-byte (logand (ash x -8) 255)))
  63   (define (write-uint24-be x)
  64     (write-byte (logand (ash x -16) 255))
  65     (write-byte (logand (ash x -8) 255))
  66     (write-byte (logand x 255)))
  67   (define (write-uint32-be x)
  68     (write-byte (logand (ash x -24) 255))
  69     (write-byte (logand (ash x -16) 255))
  70     (write-byte (logand (ash x -8) 255))
  71     (write-byte (logand x 255)))
  72   (define (write-uint32-le x)
  73     (write-byte (logand x 255))
  74     (write-byte (logand (ash x -8) 255))
  75     (write-byte (logand (ash x -16) 255))
  76     (write-byte (logand (ash x -24) 255)))
  77   (define (write-uint32 x)
  78     (case byte-order
  79       ((1234) (write-uint32-le x))
  80       ((4321) (write-uint32-be x))
  81       (else (error "unknown endianness" byte-order))))
  82   (define (write-wide-string s)
  83     (write-loader-len (* 4 (string-length s)))
  84     (string-for-each (lambda (c) (write-uint32 (char->integer c))) s))
  85   (define (write-loader-len len)
  86     (write-byte (ash len -16))
  87     (write-byte (logand (ash len -8) 255))
  88     (write-byte (logand len 255)))
  89   (define (write-loader str)
  90     (write-loader-len (string-length str))
  91     (write-string str))
  92   (define (write-bytevector bv)
  93     (write-loader-len (bytevector-length bv))
  94     ;; Ew!
  95     (for-each write-byte (bytevector->u8-list bv)))
  96   (define (write-break label)
  97     (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
  98       (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
  99             ((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
 100             (else (write-uint24-be offset)))))
 101
 102   (let ((inst (car asm))
 103         (args (cdr asm))
 104         (write-uint16 (case byte-order
 105                         ((1234) write-uint16-le)
 106                         ((4321) write-uint16-be)
 107                         (else (error "unknown endianness" byte-order)))))
 108     (let ((opcode (instruction->opcode inst))
 109           (len (instruction-length inst)))
 110       (if emit-opcode?
 111           (write-byte opcode))
 112       (pmatch asm
 113         ((load-program ,labels ,length ,meta . ,code)
 114          (write-uint32 length)
 115          (write-uint32 (if meta (1- (byte-length meta)) 0))
 116          (fold (lambda (asm address)
 117                  (let ((start (port-position port)))
 118                    (write-bytecode asm port labels address #t)
 119                    (+ address (- (port-position port) start))))
 120                0
 121                code)
 122          (if meta
 123              ;; Don't emit the `load-program' byte for metadata.  Note that
 124              ;; META's bytecode meets the alignment requirements of
 125              ;; `scm_objcode', thanks to the alignment computed in `(language
 126              ;; assembly)'.
 127              (write-bytecode meta port '() 0 #f)))
 128         ((make-char32 ,x) (write-uint32-be x))
 129         ((load-number ,str) (write-loader str))
 130         ((load-string ,str) (write-loader str))
 131         ((load-wide-string ,str) (write-wide-string str))
 132         ((load-symbol ,str) (write-loader str))
 133         ((load-array ,bv) (write-bytevector bv))
 134         ((br ,l) (write-break l))
 135         ((br-if ,l) (write-break l))
 136         ((br-if-not ,l) (write-break l))
 137         ((br-if-eq ,l) (write-break l))
 138         ((br-if-not-eq ,l) (write-break l))
 139         ((br-if-null ,l) (write-break l))
 140         ((br-if-not-null ,l) (write-break l))
 141         ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
 142         ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
 143         ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
 144         ((mv-call ,n ,l) (write-byte n) (write-break l))
 145         ((prompt ,inline-handler? ,escape-only? ,l)
 146          (write-byte inline-handler?) (write-byte escape-only?) (write-break l))
 147         (else
 148          (cond
 149           ((< (instruction-length inst) 0)
 150            (error "unhanded variable-length instruction" asm))
 151           ((not (= (length args) len))
 152            (error "bad number of args to instruction" asm len))
 153           (else
 154            (for-each write-byte args))))))))