[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/11: Heap type predicates preceded by heap-object?
From: |
Andy Wingo |
Subject: |
[Guile-commits] 03/11: Heap type predicates preceded by heap-object? |
Date: |
Sun, 29 Oct 2017 05:09:39 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 1139c10e09a35cecf81b5db37dae188a62c498f4
Author: Andy Wingo <address@hidden>
Date: Thu Oct 26 21:14:39 2017 +0200
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.
---
module/language/cps/compile-bytecode.scm | 18 ++++-
module/language/cps/primitives.scm | 134 ++++++++++++++++++++++---------
module/language/cps/type-fold.scm | 7 ++
module/language/tree-il/compile-cps.scm | 43 +++++++---
4 files changed, 150 insertions(+), 52 deletions(-)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 352436e..05eb8a6 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -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))
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index a3e6e38..71ce8de 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -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)
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index af20a3d..b811ad3 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -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)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 3e1c1d4..5f5cad8 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -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)
- (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))))))))
+ (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))))
+ ($ (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)
- (with-cps cps
- (build-term ($continue kf src
- ($branch kt ($primcall name 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)))))))))
(($ <conditional> src test consequent alternate)
(with-cps cps
(let$ t (convert-test consequent kt kf))
- [Guile-commits] branch master updated (cd947a1 -> 9d1235a), Andy Wingo, 2017/10/29
- [Guile-commits] 02/11: Use tag visitors to generate assemblers, disassembly annotations, Andy Wingo, 2017/10/29
- [Guile-commits] 05/11: Emit char? instead of br-if-char, Andy Wingo, 2017/10/29
- [Guile-commits] 04/11: Emit new instructions for heap object type tests, Andy Wingo, 2017/10/29
- [Guile-commits] 08/11: Emit new eq? instruction, Andy Wingo, 2017/10/29
- [Guile-commits] 10/11: Use new instructions for u64 comparisons., Andy Wingo, 2017/10/29
- [Guile-commits] 09/11: Use new instructions for less-than, etc, Andy Wingo, 2017/10/29
- [Guile-commits] 11/11: Use new instructions for f64 comparisons, Andy Wingo, 2017/10/29
- [Guile-commits] 03/11: Heap type predicates preceded by heap-object?,
Andy Wingo <=
- [Guile-commits] 01/11: Refactor (system base types internal) to use more macros, Andy Wingo, 2017/10/29
- [Guile-commits] 06/11: Use new instructions for null?, nil?, Andy Wingo, 2017/10/29
- [Guile-commits] 07/11: Simplify $branch to always take a $primcall, Andy Wingo, 2017/10/29