mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-18 18:40:22 +02:00
Heap type predicates preceded by heap-object?
* module/language/cps/compile-bytecode.scm (compile-function): Add support for heap-object? in test context. * module/language/cps/primitives.scm (*immediate-predicates*): (*heap-type-predicates*, *comparisons*): New sets of predicates for which the VM has branching operations. (heap-type-predicate?): New predicate. (*branching-primcall-arities*): Make a hash table. (branching-primitive?, prim-arity): Adapt to *branching-primcall-arities* being a hash table. * module/language/cps/type-fold.scm (heap-object?): Add folder. * module/language/tree-il/compile-cps.scm (convert): Precede heap type checks with a heap-object? guard.
This commit is contained in:
Andy Wingo
parent
6dd30920eb
commit
1139c10e09
4 changed files with 150 additions and 52 deletions
|
|
@ -1,6 +1,6 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2013, 2014, 2015, 2017 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
|
||||
|
|
@ -404,6 +404,21 @@
|
|||
(let ((invert? (not (prefer-true?))))
|
||||
(op asm (from-sp (slot sym)) invert? (if invert? kf kt))
|
||||
(emit-j asm (if invert? kt kf))))))
|
||||
(define (emit-branch-for-test)
|
||||
(cond
|
||||
((eq? kt next-label)
|
||||
(emit-jne asm kf))
|
||||
((eq? kf next-label)
|
||||
(emit-je asm kt))
|
||||
((prefer-true?)
|
||||
(emit-je asm kt)
|
||||
(emit-j asm kf))
|
||||
(else
|
||||
(emit-jne asm kf)
|
||||
(emit-j asm kt))))
|
||||
(define (unary* op a)
|
||||
(op asm (from-sp (slot a)))
|
||||
(emit-branch-for-test))
|
||||
(define (binary op a b)
|
||||
(cond
|
||||
((eq? kt next-label)
|
||||
|
|
@ -417,6 +432,7 @@
|
|||
(emit-j asm (if invert? kt kf))))))
|
||||
(match exp
|
||||
(($ $values (sym)) (unary emit-br-if-true sym))
|
||||
(($ $primcall 'heap-object? (a)) (unary* emit-heap-object? a))
|
||||
(($ $primcall 'null? (a)) (unary emit-br-if-null a))
|
||||
(($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
|
||||
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2013, 2014, 2015, 2017 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
|
||||
|
|
@ -30,6 +30,7 @@
|
|||
#:use-module (language bytecode)
|
||||
#:export (prim-instruction
|
||||
branching-primitive?
|
||||
heap-type-predicate?
|
||||
prim-arity
|
||||
))
|
||||
|
||||
|
|
@ -69,42 +70,97 @@
|
|||
(cached-toplevel-box . (1 . 3))
|
||||
(cached-module-box . (1 . 4))))
|
||||
|
||||
(define *branching-primcall-arities*
|
||||
'((null? . (1 . 1))
|
||||
(nil? . (1 . 1))
|
||||
(pair? . (1 . 1))
|
||||
(struct? . (1 . 1))
|
||||
(string? . (1 . 1))
|
||||
(vector? . (1 . 1))
|
||||
(symbol? . (1 . 1))
|
||||
(keyword? . (1 . 1))
|
||||
(variable? . (1 . 1))
|
||||
(bitvector? . (1 . 1))
|
||||
(bytevector? . (1 . 1))
|
||||
(char? . (1 . 1))
|
||||
(eq? . (1 . 2))
|
||||
(eqv? . (1 . 2))
|
||||
(= . (1 . 2))
|
||||
(< . (1 . 2))
|
||||
(> . (1 . 2))
|
||||
(<= . (1 . 2))
|
||||
(>= . (1 . 2))
|
||||
(u64-= . (1 . 2))
|
||||
(u64-< . (1 . 2))
|
||||
(u64-> . (1 . 2))
|
||||
(u64-<= . (1 . 2))
|
||||
(u64->= . (1 . 2))
|
||||
(u64-<-scm . (1 . 2))
|
||||
(u64-<=-scm . (1 . 2))
|
||||
(u64-=-scm . (1 . 2))
|
||||
(u64->=-scm . (1 . 2))
|
||||
(u64->-scm . (1 . 2))
|
||||
(logtest . (1 . 2))
|
||||
(f64-= . (1 . 2))
|
||||
(f64-< . (1 . 2))
|
||||
(f64-> . (1 . 2))
|
||||
(f64-<= . (1 . 2))
|
||||
(f64->= . (1 . 2))))
|
||||
(define *immediate-predicates*
|
||||
'(fixnum?
|
||||
char?
|
||||
eq-nil?
|
||||
eq-eol?
|
||||
eq-false?
|
||||
eq-true?
|
||||
unspecified?
|
||||
undefined?
|
||||
eof-object?
|
||||
null? ;; '() or #nil
|
||||
false? ;; #f or #nil
|
||||
nil? ;; #f or '() or #nil
|
||||
heap-object?))
|
||||
|
||||
;; All of the following tests must be dominated by heap-object?.
|
||||
(define *heap-type-predicates*
|
||||
'(pair?
|
||||
struct?
|
||||
symbol?
|
||||
variable?
|
||||
vector?
|
||||
string?
|
||||
keyword?
|
||||
bytevector?
|
||||
bitvector?))
|
||||
|
||||
;; FIXME: Support these.
|
||||
(define *other-predicates*
|
||||
'(weak-vector?
|
||||
number?
|
||||
hash-table?
|
||||
pointer?
|
||||
fluid?
|
||||
stringbuf?
|
||||
dynamic-state?
|
||||
frame?
|
||||
syntax?
|
||||
program?
|
||||
vm-continuation?
|
||||
weak-set?
|
||||
weak-table?
|
||||
array?
|
||||
port?
|
||||
smob?
|
||||
bignum?
|
||||
flonum?
|
||||
complex?
|
||||
fraction?))
|
||||
|
||||
(define (heap-type-predicate? name)
|
||||
"Is @var{name} a predicate that needs guarding by @code{heap-object?}
|
||||
before it is lowered to CPS?"
|
||||
(and (memq name *heap-type-predicates*) #t))
|
||||
|
||||
(define *comparisons*
|
||||
'(eq?
|
||||
eqv?
|
||||
<
|
||||
<=
|
||||
=
|
||||
u64-<
|
||||
u64-<=
|
||||
u64-=
|
||||
f64-=
|
||||
f64-<
|
||||
f64-<=
|
||||
|
||||
;; FIXME: Expand these.
|
||||
logtest
|
||||
u64-<-scm
|
||||
u64-<=-scm
|
||||
u64-=-scm
|
||||
|
||||
;; FIXME: Remove these.
|
||||
>
|
||||
>=
|
||||
u64->
|
||||
u64->=
|
||||
u64->=-scm
|
||||
u64->-scm
|
||||
f64->
|
||||
f64->=))
|
||||
|
||||
(define *branching-primcall-arities* (make-hash-table))
|
||||
(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 1)))
|
||||
*immediate-predicates*)
|
||||
(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 1)))
|
||||
*heap-type-predicates*)
|
||||
(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 2)))
|
||||
*comparisons*)
|
||||
|
||||
(define (compute-prim-instructions)
|
||||
(let ((table (make-hash-table)))
|
||||
|
|
@ -126,7 +182,7 @@
|
|||
(hashq-ref (force *prim-instructions*) name))
|
||||
|
||||
(define (branching-primitive? name)
|
||||
(and (assq name *branching-primcall-arities*) #t))
|
||||
(and (hashq-ref *branching-primcall-arities* name) #t))
|
||||
|
||||
(define *prim-arities* (make-hash-table))
|
||||
|
||||
|
|
@ -134,7 +190,7 @@
|
|||
(or (hashq-ref *prim-arities* name)
|
||||
(let ((arity (cond
|
||||
((prim-instruction name) => instruction-arity)
|
||||
((assq name *branching-primcall-arities*) => cdr)
|
||||
((hashq-ref *branching-primcall-arities* name))
|
||||
(else
|
||||
(error "Primitive of unknown arity" name)))))
|
||||
(hashq-set! *prim-arities* name arity)
|
||||
|
|
|
|||
|
|
@ -90,6 +90,13 @@
|
|||
((eqv? type type*) (values #t #t))
|
||||
(else (values #f #f))))))
|
||||
|
||||
(define-unary-branch-folder (heap-object? type min max)
|
||||
(define &immediate-types (logior &fixnum &char &special-immediate))
|
||||
(cond
|
||||
((zero? (logand type &immediate-types)) (values #t #t))
|
||||
((type<=? type &immediate-types) (values #t #f))
|
||||
(else (values #f #f))))
|
||||
|
||||
;; All the cases that are in compile-bytecode.
|
||||
(define-unary-type-predicate-folder pair? &pair)
|
||||
(define-unary-type-predicate-folder symbol? &symbol)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2013, 2014, 2015, 2017 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
|
||||
|
|
@ -522,14 +522,25 @@
|
|||
(build-term ($continue kf* src
|
||||
($branch kt ($primcall 'eqv? args))))))))
|
||||
((branching-primitive? name)
|
||||
(let ()
|
||||
(define (reify-primcall cps kt kf args)
|
||||
(if (heap-type-predicate? name)
|
||||
(with-cps cps
|
||||
(letk kt* ($kargs () ()
|
||||
($continue kf src
|
||||
($branch kt ($primcall name args)))))
|
||||
(build-term ($continue kf src
|
||||
($branch kt* ($primcall 'heap-object? args)))))
|
||||
(with-cps cps
|
||||
(build-term ($continue kf src
|
||||
($branch kt ($primcall name args)))))))
|
||||
(convert-args cps args
|
||||
(lambda (cps args)
|
||||
(with-cps cps
|
||||
(let$ k (adapt-arity k src 1))
|
||||
(letk kt ($kargs () () ($continue k src ($const #t))))
|
||||
(letk kf ($kargs () () ($continue k src ($const #f))))
|
||||
(build-term ($continue kf src
|
||||
($branch kt ($primcall name args))))))))
|
||||
($ (reify-primcall kt kf args)))))))
|
||||
((and (eq? name 'not) (match args ((_) #t) (_ #f)))
|
||||
(convert-args cps args
|
||||
(lambda (cps args)
|
||||
|
|
@ -788,9 +799,17 @@
|
|||
(($ <primcall> src (? branching-primitive? name) args)
|
||||
(convert-args cps args
|
||||
(lambda (cps args)
|
||||
(if (heap-type-predicate? name)
|
||||
(with-cps cps
|
||||
(letk kt* ($kargs () ()
|
||||
($continue kf src
|
||||
($branch kt ($primcall name args)))))
|
||||
(build-term
|
||||
($continue kf src
|
||||
($branch kt* ($primcall 'heap-object? args)))))
|
||||
(with-cps cps
|
||||
(build-term ($continue kf src
|
||||
($branch kt ($primcall name args))))))))
|
||||
($branch kt ($primcall name args)))))))))
|
||||
(($ <conditional> src test consequent alternate)
|
||||
(with-cps cps
|
||||
(let$ t (convert-test consequent kt kf))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue