Commit | Line | Data |
---|---|---|
691697de | 1 | ;;; Bytecode |
43f768f4 AW |
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 | ||
691697de | 21 | (define-module (language bytecode) |
43f768f4 AW |
22 | #:use-module (ice-9 match) |
23 | #:use-module ((srfi srfi-1) #:select (fold)) | |
1b780c13 | 24 | #:export (instruction-list |
691697de | 25 | instruction-arity |
486013d6 AW |
26 | builtin-name->index |
27 | builtin-index->name)) | |
28 | ||
1b780c13 AW |
29 | (load-extension (string-append "libguile-" (effective-version)) |
30 | "scm_init_instructions") | |
486013d6 AW |
31 | (load-extension (string-append "libguile-" (effective-version)) |
32 | "scm_init_vm_builtins") | |
43f768f4 | 33 | |
691697de | 34 | (define (compute-instruction-arity name args) |
43f768f4 AW |
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 | ||
691697de | 77 | (define (compute-instruction-arities) |
43f768f4 AW |
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 | |
691697de | 84 | (cons 0 (compute-instruction-arity name args)))) |
43f768f4 AW |
85 | ((name op '<- . args) |
86 | (hashq-set! table name | |
691697de | 87 | (cons 1 (1- (compute-instruction-arity name args)))))) |
1b780c13 | 88 | (instruction-list)) |
43f768f4 AW |
89 | (for-each (match-lambda |
90 | ((name . arity) | |
91 | (hashq-set! table name arity))) | |
92 | *macro-instruction-arities*) | |
93 | table)) | |
94 | ||
691697de | 95 | (define *instruction-arities* (delay (compute-instruction-arities))) |
43f768f4 | 96 | |
691697de AW |
97 | (define (instruction-arity name) |
98 | (hashq-ref (force *instruction-arities*) name)) |