mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
d238566d0e
* module/language/cps/compile-bytecode.scm (compile-function): Expect eq-constant? instead of eq-null?, etc. * module/language/cps/effects-analysis.scm: Likewise. * module/language/cps/reify-primitives.scm (reify-primitives): For eq-constant?, reify a $const unless the constant is an immediate whose encoding fits in 16 bits. * module/language/cps/type-fold.scm (materialize-constant): Helper to make a constant from a type, min, and max. (fold-eq-constant?): New helper. (eq-constant?): New folder. (undefined?): Define specifically. (define-nullish-predicate-folder): Renamd from define-special-immediate-predicate-folder. Use only for null?, false, and nil?. (*branch-reducers*): New mechanism. Reduce eq? to eq-constant? if possible. (local-type-fold): Refactor to use materialize-constant, and to allow reducing branches. * module/language/cps/types.scm (constant-type): Return three values instead of a type entry. (constant-type-entry): New function that returns a type entry. Adapt callers. (infer-constant-comparison): New helper. (eq-constant?): New inferrer. (undefined?): New inferrer. * module/language/tree-il/compile-bytecode.scm (eq-constant?): Fix truncate-bits signed arg. (define-immediate-type-predicate): Adapt to visit-immediate-tags change. * module/language/tree-il/compile-cps.scm (convert): Convert eq? to constant to eq-constant?. Advantaged is that it gets fixnums and chars in addition to special immediates. * module/language/tree-il/cps-primitives.scm (define-immediate-type-predicate): Adapt to allow #f as pred. * module/system/base/types/internal.scm (immediate-tags): Use #f as pred for false, nil, etc. (immediate-bits->scm): Adapt. * module/system/vm/assembler.scm (emit-eq-null?, emit-eq-nil?) (emit-eq-false?, emit-eq-true?, emit-unspecified?, emit-eof-object?): Remove specialized emitters. * module/system/vm/assembler.scm (define-immediate-tag=?-macro-assembler): Allow for pred to be #f. * module/system/vm/disassembler.scm (define-immediate-tag-annotation): Adapt to pred being #f.
193 lines
7.4 KiB
Scheme
193 lines
7.4 KiB
Scheme
;;; Continuation-passing style (CPS) intermediate language (IL)
|
|
|
|
;; Copyright (C) 2013-2015, 2017-2020 Free Software Foundation, Inc.
|
|
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; Information about named primitives, as they appear in $prim and
|
|
;;; $primcall.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define-module (language tree-il cps-primitives)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (language bytecode)
|
|
#:use-module (system base types internal)
|
|
#:export (tree-il-primitive->cps-primitive+nargs+nvalues
|
|
branching-primitive?
|
|
heap-type-predicate?))
|
|
|
|
(define *primitives* (make-hash-table))
|
|
|
|
(define-syntax define-cps-primitive
|
|
(syntax-rules ()
|
|
((_ (tree-il-primitive cps-primitive) nargs nvalues)
|
|
(hashq-set! *primitives* 'tree-il-primitive
|
|
'#(cps-primitive nargs nvalues)))
|
|
((_ primitive nargs nvalues)
|
|
(define-cps-primitive (primitive primitive) nargs nvalues))))
|
|
|
|
;; tree-il-prim -> #(cps-prim nargs nvalues) | #f
|
|
(define (tree-il-primitive->cps-primitive+nargs+nvalues name)
|
|
(hashq-ref *primitives* name))
|
|
|
|
(define-cps-primitive box 1 1)
|
|
(define-cps-primitive (variable-ref box-ref) 1 1)
|
|
(define-cps-primitive (variable-set! box-set!) 2 0)
|
|
(define-cps-primitive (%variable-ref %box-ref) 1 1)
|
|
(define-cps-primitive (%variable-set! %box-set!) 2 0)
|
|
|
|
(define-cps-primitive current-module 0 1)
|
|
(define-cps-primitive (module-ensure-local-variable! define!) 2 1)
|
|
|
|
(define-cps-primitive wind 2 0)
|
|
(define-cps-primitive unwind 0 0)
|
|
(define-cps-primitive push-dynamic-state 1 0)
|
|
(define-cps-primitive pop-dynamic-state 0 0)
|
|
|
|
(define-cps-primitive push-fluid 2 0)
|
|
(define-cps-primitive pop-fluid 0 0)
|
|
(define-cps-primitive fluid-ref 1 1)
|
|
(define-cps-primitive fluid-set! 2 0)
|
|
|
|
(define-cps-primitive string-length 1 1)
|
|
(define-cps-primitive string-ref 2 1)
|
|
(define-cps-primitive string-set! 3 0)
|
|
(define-cps-primitive string->number 1 1)
|
|
(define-cps-primitive string->symbol 1 1)
|
|
(define-cps-primitive symbol->keyword 1 1)
|
|
|
|
(define-cps-primitive integer->char 1 1)
|
|
(define-cps-primitive char->integer 1 1)
|
|
|
|
(define-cps-primitive cons 2 1)
|
|
(define-cps-primitive car 1 1)
|
|
(define-cps-primitive cdr 1 1)
|
|
(define-cps-primitive set-car! 2 0)
|
|
(define-cps-primitive set-cdr! 2 0)
|
|
|
|
(define-cps-primitive (+ add) 2 1)
|
|
(define-cps-primitive (- sub) 2 1)
|
|
(define-cps-primitive (* mul) 2 1)
|
|
(define-cps-primitive (/ div) 2 1)
|
|
(define-cps-primitive (quotient quo) 2 1)
|
|
(define-cps-primitive (remainder rem) 2 1)
|
|
(define-cps-primitive (modulo mod) 2 1)
|
|
(define-cps-primitive (exact->inexact inexact) 1 1)
|
|
(define-cps-primitive sqrt 1 1)
|
|
(define-cps-primitive abs 1 1)
|
|
(define-cps-primitive floor 1 1)
|
|
(define-cps-primitive ceiling 1 1)
|
|
(define-cps-primitive sin 1 1)
|
|
(define-cps-primitive cos 1 1)
|
|
(define-cps-primitive tan 1 1)
|
|
(define-cps-primitive asin 1 1)
|
|
(define-cps-primitive acos 1 1)
|
|
(define-cps-primitive atan 1 1)
|
|
(define-cps-primitive atan2 2 1)
|
|
|
|
(define-cps-primitive lsh 2 1)
|
|
(define-cps-primitive rsh 2 1)
|
|
(define-cps-primitive logand 2 1)
|
|
(define-cps-primitive logior 2 1)
|
|
(define-cps-primitive logxor 2 1)
|
|
(define-cps-primitive logsub 2 1)
|
|
(define-cps-primitive logbit? 2 1)
|
|
|
|
(define-cps-primitive allocate-vector 1 1)
|
|
(define-cps-primitive make-vector 2 1)
|
|
(define-cps-primitive vector-length 1 1)
|
|
(define-cps-primitive vector-ref 2 1)
|
|
(define-cps-primitive vector-set! 3 0)
|
|
(define-cps-primitive vector-init! 3 0)
|
|
|
|
(define-cps-primitive struct-vtable 1 1)
|
|
(define-cps-primitive allocate-struct 2 1)
|
|
(define-cps-primitive struct-ref 2 1)
|
|
;; Unhappily, and undocumentedly, struct-set! returns the value that was
|
|
;; set. There is code that relies on this. The struct-set! lowering
|
|
;; routines ensure this return arity.
|
|
(define-cps-primitive struct-set! 3 1)
|
|
(define-cps-primitive struct-init! 3 0)
|
|
|
|
(define-cps-primitive class-of 1 1)
|
|
|
|
(define-cps-primitive (bytevector-length bv-length) 1 1)
|
|
(define-cps-primitive (bytevector-u8-ref bv-u8-ref) 2 1)
|
|
(define-cps-primitive (bytevector-u16-native-ref bv-u16-ref) 2 1)
|
|
(define-cps-primitive (bytevector-u32-native-ref bv-u32-ref) 2 1)
|
|
(define-cps-primitive (bytevector-u64-native-ref bv-u64-ref) 2 1)
|
|
(define-cps-primitive (bytevector-s8-ref bv-s8-ref) 2 1)
|
|
(define-cps-primitive (bytevector-s16-native-ref bv-s16-ref) 2 1)
|
|
(define-cps-primitive (bytevector-s32-native-ref bv-s32-ref) 2 1)
|
|
(define-cps-primitive (bytevector-s64-native-ref bv-s64-ref) 2 1)
|
|
(define-cps-primitive (bytevector-ieee-single-native-ref bv-f32-ref) 2 1)
|
|
(define-cps-primitive (bytevector-ieee-double-native-ref bv-f64-ref) 2 1)
|
|
(define-cps-primitive (bytevector-u8-set! bv-u8-set!) 3 0)
|
|
(define-cps-primitive (bytevector-u16-native-set! bv-u16-set!) 3 0)
|
|
(define-cps-primitive (bytevector-u32-native-set! bv-u32-set!) 3 0)
|
|
(define-cps-primitive (bytevector-u64-native-set! bv-u64-set!) 3 0)
|
|
(define-cps-primitive (bytevector-s8-set! bv-s8-set!) 3 0)
|
|
(define-cps-primitive (bytevector-s16-native-set! bv-s16-set!) 3 0)
|
|
(define-cps-primitive (bytevector-s32-native-set! bv-s32-set!) 3 0)
|
|
(define-cps-primitive (bytevector-s64-native-set! bv-s64-set!) 3 0)
|
|
(define-cps-primitive (bytevector-ieee-single-native-set! bv-f32-set!) 3 0)
|
|
(define-cps-primitive (bytevector-ieee-double-native-set! bv-f64-set!) 3 0)
|
|
|
|
(define-cps-primitive current-thread 0 1)
|
|
|
|
(define-cps-primitive make-atomic-box 1 1)
|
|
(define-cps-primitive atomic-box-ref 1 1)
|
|
(define-cps-primitive atomic-box-set! 2 0)
|
|
(define-cps-primitive atomic-box-swap! 2 1)
|
|
(define-cps-primitive atomic-box-compare-and-swap! 3 1)
|
|
|
|
(define *branching-primitive-arities* (make-hash-table))
|
|
(define-syntax-rule (define-branching-primitive name nargs)
|
|
(hashq-set! *branching-primitive-arities* 'name '(0 . nargs)))
|
|
|
|
(define-syntax define-immediate-type-predicate
|
|
(syntax-rules ()
|
|
((_ name #f mask tag) #f)
|
|
((_ name pred mask tag)
|
|
(define-branching-primitive pred 1))))
|
|
(define *heap-type-predicates* (make-hash-table))
|
|
(define-syntax-rule (define-heap-type-predicate name pred mask tag)
|
|
(begin
|
|
(hashq-set! *heap-type-predicates* 'pred #t)
|
|
(define-branching-primitive pred 1)))
|
|
|
|
(visit-immediate-tags define-immediate-type-predicate)
|
|
(visit-heap-tags define-heap-type-predicate)
|
|
|
|
(define (branching-primitive? name)
|
|
"Is @var{name} a primitive that can only appear in $branch CPS terms?"
|
|
(hashq-ref *branching-primitive-arities* name))
|
|
|
|
(define (heap-type-predicate? name)
|
|
"Is @var{name} a predicate that needs guarding by @code{heap-object?}
|
|
before it is lowered to CPS?"
|
|
(hashq-ref *heap-type-predicates* name))
|
|
|
|
;; We only need to define those branching primitives that are used as
|
|
;; Tree-IL primitives. There are others like u64-= which are emitted by
|
|
;; CPS code.
|
|
(define-branching-primitive eq? 2)
|
|
(define-branching-primitive heap-numbers-equal? 2)
|
|
(define-branching-primitive < 2)
|
|
(define-branching-primitive <= 2)
|
|
(define-branching-primitive = 2)
|