module/language/bytecode.scm

   1 ;;; Bytecode
   2
   3 ;; Copyright (C) 2013 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 bytecode)
  22   #:use-module (ice-9 match)
  23   #:use-module ((srfi srfi-1) #:select (fold))
  24   #:export (instruction-list
  25             instruction-arity
  26             builtin-name->index
  27             builtin-index->name))
  28
  29 (load-extension (string-append "libguile-" (effective-version))
  30                 "scm_init_instructions")
  31 (load-extension (string-append "libguile-" (effective-version))
  32                 "scm_init_vm_builtins")
  33
  34 (define (compute-instruction-arity name args)
  35   (define (first-word-arity word)
  36     (case word
  37       ((U8_X24) 0)
  38       ((U8_U24) 1)
  39       ((U8_L24) 1)
  40       ((U8_U8_I16) 2)
  41       ((U8_U12_U12) 2)
  42       ((U8_U8_U8_U8) 3)))
  43   (define (tail-word-arity word)
  44     (case word
  45       ((U8_U24) 2)
  46       ((U8_L24) 2)
  47       ((U8_U8_I16) 3)
  48       ((U8_U12_U12) 3)
  49       ((U8_U8_U8_U8) 4)
  50       ((U32) 1)
  51       ((I32) 1)
  52       ((A32) 1)
  53       ((B32) 0)
  54       ((N32) 1)
  55       ((S32) 1)
  56       ((L32) 1)
  57       ((LO32) 1)
  58       ((X8_U24) 1)
  59       ((X8_U12_U12) 2)
  60       ((X8_L24) 1)
  61       ((B1_X7_L24) 2)
  62       ((B1_U7_L24) 3)
  63       ((B1_X31) 1)
  64       ((B1_X7_U24) 2)))
  65   (match args
  66     ((arg0 . args)
  67      (fold (lambda (arg arity)
  68              (+ (tail-word-arity arg) arity))
  69            (first-word-arity arg0)
  70            args))))
  71
  72 (define *macro-instruction-arities*
  73   '((cache-current-module! . (0 . 2))
  74     (cached-toplevel-box . (1 . 3))
  75     (cached-module-box . (1 . 4))))
  76
  77 (define (compute-instruction-arities)
  78   (let ((table (make-hash-table)))
  79     (for-each
  80      (match-lambda
  81       ;; Put special cases here.
  82       ((name op '! . args)
  83        (hashq-set! table name
  84                    (cons 0 (compute-instruction-arity name args))))
  85       ((name op '<- . args)
  86        (hashq-set! table name
  87                    (cons 1 (1- (compute-instruction-arity name args))))))
  88      (instruction-list))
  89     (for-each (match-lambda
  90                ((name . arity)
  91                 (hashq-set! table name arity)))
  92               *macro-instruction-arities*)
  93     table))
  94
  95 (define *instruction-arities* (delay (compute-instruction-arities)))
  96
  97 (define (instruction-arity name)
  98   (hashq-ref (force *instruction-arities*) name))