Commit | Line | Data |
---|---|---|
045392f1 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
e2fafeb9 | 3 | ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. |
045392f1 AW |
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 | ;;; Commentary: | |
20 | ;;; | |
92805e21 AW |
21 | ;;; Information about named primitives, as they appear in $prim and |
22 | ;;; $primcall. | |
045392f1 AW |
23 | ;;; |
24 | ;;; Code: | |
25 | ||
26 | (define-module (language cps primitives) | |
27 | #:use-module (ice-9 match) | |
28 | #:use-module ((srfi srfi-1) #:select (fold)) | |
29 | #:use-module (srfi srfi-26) | |
691697de AW |
30 | #:use-module (language bytecode) |
31 | #:export (prim-instruction | |
045392f1 AW |
32 | branching-primitive? |
33 | prim-arity | |
34 | )) | |
35 | ||
691697de | 36 | (define *instruction-aliases* |
045392f1 AW |
37 | '((+ . add) (1+ . add1) |
38 | (- . sub) (1- . sub1) | |
39 | (* . mul) (/ . div) | |
40 | (quotient . quo) (remainder . rem) | |
41 | (modulo . mod) | |
4f406fea | 42 | (variable-ref . box-ref) |
6165d812 | 43 | (variable-set! . box-set!) |
d59060ce | 44 | (bytevector-u8-ref . bv-u8-ref) |
6165d812 AW |
45 | (bytevector-u16-native-ref . bv-u16-ref) |
46 | (bytevector-u32-native-ref . bv-u32-ref) | |
47 | (bytevector-u64-native-ref . bv-u64-ref) | |
d59060ce | 48 | (bytevector-s8-ref . bv-s8-ref) |
6165d812 AW |
49 | (bytevector-s16-native-ref . bv-s16-ref) |
50 | (bytevector-s32-native-ref . bv-s32-ref) | |
51 | (bytevector-s64-native-ref . bv-s64-ref) | |
9253198b AW |
52 | (bytevector-ieee-single-native-ref . bv-f32-ref) |
53 | (bytevector-ieee-double-native-ref . bv-f64-ref) | |
d59060ce | 54 | (bytevector-u8-set! . bv-u8-set!) |
6165d812 AW |
55 | (bytevector-u16-native-set! . bv-u16-set!) |
56 | (bytevector-u32-native-set! . bv-u32-set!) | |
57 | (bytevector-u64-native-set! . bv-u64-set!) | |
d59060ce | 58 | (bytevector-s8-set! . bv-s8-set!) |
6165d812 AW |
59 | (bytevector-s16-native-set! . bv-s16-set!) |
60 | (bytevector-s32-native-set! . bv-s32-set!) | |
61 | (bytevector-s64-native-set! . bv-s64-set!) | |
9253198b AW |
62 | (bytevector-ieee-single-native-set! . bv-f32-set!) |
63 | (bytevector-ieee-double-native-set! . bv-f64-set!))) | |
045392f1 AW |
64 | |
65 | (define *macro-instruction-arities* | |
66 | '((cache-current-module! . (0 . 2)) | |
67 | (cached-toplevel-box . (1 . 3)) | |
68 | (cached-module-box . (1 . 4)))) | |
69 | ||
70 | (define *branching-primcall-arities* | |
71 | '((null? . (1 . 1)) | |
72 | (nil? . (1 . 1)) | |
73 | (pair? . (1 . 1)) | |
74 | (struct? . (1 . 1)) | |
be8b62ca AW |
75 | (string? . (1 . 1)) |
76 | (vector? . (1 . 1)) | |
77 | (symbol? . (1 . 1)) | |
e2fafeb9 | 78 | (keyword? . (1 . 1)) |
be8b62ca | 79 | (variable? . (1 . 1)) |
d65514a2 | 80 | (bitvector? . (1 . 1)) |
becce37b | 81 | (bytevector? . (1 . 1)) |
045392f1 AW |
82 | (char? . (1 . 1)) |
83 | (eq? . (1 . 2)) | |
84 | (eqv? . (1 . 2)) | |
85 | (equal? . (1 . 2)) | |
86 | (= . (1 . 2)) | |
87 | (< . (1 . 2)) | |
88 | (> . (1 . 2)) | |
89 | (<= . (1 . 2)) | |
d613ccaa AW |
90 | (>= . (1 . 2)) |
91 | (logtest . (1 . 2)))) | |
045392f1 | 92 | |
691697de | 93 | (define (compute-prim-instructions) |
045392f1 AW |
94 | (let ((table (make-hash-table))) |
95 | (for-each | |
96 | (match-lambda ((inst . _) (hashq-set! table inst inst))) | |
1b780c13 | 97 | (instruction-list)) |
045392f1 AW |
98 | (for-each |
99 | (match-lambda ((prim . inst) (hashq-set! table prim inst))) | |
691697de | 100 | *instruction-aliases*) |
045392f1 AW |
101 | (for-each |
102 | (match-lambda ((inst . arity) (hashq-set! table inst inst))) | |
103 | *macro-instruction-arities*) | |
104 | table)) | |
105 | ||
691697de | 106 | (define *prim-instructions* (delay (compute-prim-instructions))) |
045392f1 | 107 | |
691697de AW |
108 | ;; prim -> instruction | #f |
109 | (define (prim-instruction name) | |
110 | (hashq-ref (force *prim-instructions*) name)) | |
045392f1 AW |
111 | |
112 | (define (branching-primitive? name) | |
113 | (and (assq name *branching-primcall-arities*) #t)) | |
114 | ||
115 | (define *prim-arities* (make-hash-table)) | |
116 | ||
117 | (define (prim-arity name) | |
118 | (or (hashq-ref *prim-arities* name) | |
119 | (let ((arity (cond | |
691697de | 120 | ((prim-instruction name) => instruction-arity) |
045392f1 AW |
121 | ((assq name *branching-primcall-arities*) => cdr) |
122 | (else | |
123 | (error "Primitive of unknown arity" name))))) | |
124 | (hashq-set! *prim-arities* name arity) | |
125 | arity))) |