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