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