module/language/assembly/compile-bytecode.scm

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