guile-commits
[Top][All Lists]
Advanced

[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))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]