1;;; Continuation-passing style (CPS) intermediate language (IL)
2
3;; Copyright (C) 2013-2015, 2017-2020 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;;; Commentary:
20;;;
21;;; Information about named primitives, as they appear in $prim and
22;;; $primcall.
23;;;
24;;; Code:
25
26(define-module (language tree-il cps-primitives)
27  #:use-module (ice-9 match)
28  #:use-module (language bytecode)
29  #:use-module (system base types internal)
30  #:export (tree-il-primitive->cps-primitive+nargs+nvalues
31            branching-primitive?
32            heap-type-predicate?))
33
34(define *primitives* (make-hash-table))
35
36(define-syntax define-cps-primitive
37  (syntax-rules ()
38    ((_ (tree-il-primitive cps-primitive) nargs nvalues)
39     (hashq-set! *primitives* 'tree-il-primitive
40                 '#(cps-primitive nargs nvalues)))
41    ((_ primitive nargs nvalues)
42     (define-cps-primitive (primitive primitive) nargs nvalues))))
43
44;; tree-il-prim -> #(cps-prim nargs nvalues) | #f
45(define (tree-il-primitive->cps-primitive+nargs+nvalues name)
46  (hashq-ref *primitives* name))
47
48(define-cps-primitive box 1 1)
49(define-cps-primitive (variable-ref box-ref) 1 1)
50(define-cps-primitive (variable-set! box-set!) 2 0)
51(define-cps-primitive (%variable-ref %box-ref) 1 1)
52(define-cps-primitive (%variable-set! %box-set!) 2 0)
53
54(define-cps-primitive current-module 0 1)
55(define-cps-primitive (module-ensure-local-variable! define!) 2 1)
56
57(define-cps-primitive wind 2 0)
58(define-cps-primitive unwind 0 0)
59(define-cps-primitive push-dynamic-state 1 0)
60(define-cps-primitive pop-dynamic-state 0 0)
61
62(define-cps-primitive push-fluid 2 0)
63(define-cps-primitive pop-fluid 0 0)
64(define-cps-primitive fluid-ref 1 1)
65(define-cps-primitive fluid-set! 2 0)
66
67(define-cps-primitive string-length 1 1)
68(define-cps-primitive string-ref 2 1)
69(define-cps-primitive string-set! 3 0)
70(define-cps-primitive string->number 1 1)
71(define-cps-primitive string->symbol 1 1)
72(define-cps-primitive symbol->keyword 1 1)
73
74(define-cps-primitive integer->char 1 1)
75(define-cps-primitive char->integer 1 1)
76
77(define-cps-primitive cons 2 1)
78(define-cps-primitive car 1 1)
79(define-cps-primitive cdr 1 1)
80(define-cps-primitive set-car! 2 0)
81(define-cps-primitive set-cdr! 2 0)
82
83(define-cps-primitive (+ add) 2 1)
84(define-cps-primitive (- sub) 2 1)
85(define-cps-primitive (* mul) 2 1)
86(define-cps-primitive (/ div) 2 1)
87(define-cps-primitive (quotient quo) 2 1)
88(define-cps-primitive (remainder rem) 2 1)
89(define-cps-primitive (modulo mod) 2 1)
90(define-cps-primitive (exact->inexact inexact) 1 1)
91(define-cps-primitive sqrt 1 1)
92(define-cps-primitive abs 1 1)
93(define-cps-primitive floor 1 1)
94(define-cps-primitive ceiling 1 1)
95(define-cps-primitive sin 1 1)
96(define-cps-primitive cos 1 1)
97(define-cps-primitive tan 1 1)
98(define-cps-primitive asin 1 1)
99(define-cps-primitive acos 1 1)
100(define-cps-primitive atan 1 1)
101(define-cps-primitive atan2 2 1)
102
103(define-cps-primitive lsh 2 1)
104(define-cps-primitive rsh 2 1)
105(define-cps-primitive logand 2 1)
106(define-cps-primitive logior 2 1)
107(define-cps-primitive logxor 2 1)
108(define-cps-primitive logsub 2 1)
109(define-cps-primitive logbit? 2 1)
110
111(define-cps-primitive allocate-vector 1 1)
112(define-cps-primitive make-vector 2 1)
113(define-cps-primitive vector-length 1 1)
114(define-cps-primitive vector-ref 2 1)
115(define-cps-primitive vector-set! 3 0)
116(define-cps-primitive vector-init! 3 0)
117
118(define-cps-primitive struct-vtable 1 1)
119(define-cps-primitive allocate-struct 2 1)
120(define-cps-primitive struct-ref 2 1)
121;; Unhappily, and undocumentedly, struct-set! returns the value that was
122;; set.  There is code that relies on this.  The struct-set! lowering
123;; routines ensure this return arity.
124(define-cps-primitive struct-set! 3 1)
125(define-cps-primitive struct-init! 3 0)
126
127(define-cps-primitive class-of 1 1)
128
129(define-cps-primitive (bytevector-length bv-length) 1 1)
130(define-cps-primitive (bytevector-u8-ref bv-u8-ref) 2 1)
131(define-cps-primitive (bytevector-u16-native-ref bv-u16-ref) 2 1)
132(define-cps-primitive (bytevector-u32-native-ref bv-u32-ref) 2 1)
133(define-cps-primitive (bytevector-u64-native-ref bv-u64-ref) 2 1)
134(define-cps-primitive (bytevector-s8-ref bv-s8-ref) 2 1)
135(define-cps-primitive (bytevector-s16-native-ref bv-s16-ref) 2 1)
136(define-cps-primitive (bytevector-s32-native-ref bv-s32-ref) 2 1)
137(define-cps-primitive (bytevector-s64-native-ref bv-s64-ref) 2 1)
138(define-cps-primitive (bytevector-ieee-single-native-ref bv-f32-ref) 2 1)
139(define-cps-primitive (bytevector-ieee-double-native-ref bv-f64-ref) 2 1)
140(define-cps-primitive (bytevector-u8-set! bv-u8-set!) 3 0)
141(define-cps-primitive (bytevector-u16-native-set! bv-u16-set!) 3 0)
142(define-cps-primitive (bytevector-u32-native-set! bv-u32-set!) 3 0)
143(define-cps-primitive (bytevector-u64-native-set! bv-u64-set!) 3 0)
144(define-cps-primitive (bytevector-s8-set! bv-s8-set!) 3 0)
145(define-cps-primitive (bytevector-s16-native-set! bv-s16-set!) 3 0)
146(define-cps-primitive (bytevector-s32-native-set! bv-s32-set!) 3 0)
147(define-cps-primitive (bytevector-s64-native-set! bv-s64-set!) 3 0)
148(define-cps-primitive (bytevector-ieee-single-native-set! bv-f32-set!) 3 0)
149(define-cps-primitive (bytevector-ieee-double-native-set! bv-f64-set!) 3 0)
150
151(define-cps-primitive current-thread 0 1)
152
153(define-cps-primitive make-atomic-box 1 1)
154(define-cps-primitive atomic-box-ref 1 1)
155(define-cps-primitive atomic-box-set! 2 0)
156(define-cps-primitive atomic-box-swap! 2 1)
157(define-cps-primitive atomic-box-compare-and-swap! 3 1)
158
159(define *branching-primitive-arities* (make-hash-table))
160(define-syntax-rule (define-branching-primitive name nargs)
161  (hashq-set! *branching-primitive-arities* 'name '(0 . nargs)))
162
163(define-syntax define-immediate-type-predicate
164  (syntax-rules ()
165    ((_ name #f mask tag) #f)
166    ((_ name pred mask tag)
167     (define-branching-primitive pred 1))))
168(define *heap-type-predicates* (make-hash-table))
169(define-syntax-rule (define-heap-type-predicate name pred mask tag)
170  (begin
171    (hashq-set! *heap-type-predicates* 'pred #t)
172    (define-branching-primitive pred 1)))
173
174(visit-immediate-tags define-immediate-type-predicate)
175(visit-heap-tags define-heap-type-predicate)
176
177(define (branching-primitive? name)
178  "Is @var{name} a primitive that can only appear in $branch CPS terms?"
179  (hashq-ref *branching-primitive-arities* name))
180
181(define (heap-type-predicate? name)
182  "Is @var{name} a predicate that needs guarding by @code{heap-object?}
183 before it is lowered to CPS?"
184  (hashq-ref *heap-type-predicates* name))
185
186;; We only need to define those branching primitives that are used as
187;; Tree-IL primitives.  There are others like u64-= which are emitted by
188;; CPS code.
189(define-branching-primitive eq? 2)
190(define-branching-primitive heap-numbers-equal? 2)
191(define-branching-primitive < 2)
192(define-branching-primitive <= 2)
193(define-branching-primitive = 2)
194