guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 07/07: Model all special immediates under one type bit (


From: Andy Wingo
Subject: [Guile-commits] 07/07: Model all special immediates under one type bit (with range)
Date: Thu, 26 Oct 2017 10:07:17 -0400 (EDT)

wingo pushed a commit to branch master
in repository guile.

commit cd947a1161fcdddb30fc2400d9732f9330deb8e0
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 26 15:51:28 2017 +0200

    Model all special immediates under one type bit (with range)
    
    * module/language/cps/types.scm (&special-immediate): Model all special
      immediates (iflags) under this type bit.  This makes type analysis
      less precise on these values as we have to use ranges instead of sets
      to represent the values, but it frees up bits for other purposes,
      allowing us to totally model all types in Guile.
      (&eof): New &special-immediate value.
      (&other-heap-object): New type bit.
      Adapt inferrers.
    * module/language/cps/type-fold.scm
      (define-special-immediate-predicate-folder): New helper, used for
      iflag comparisons.
      (local-type-fold): Adapt scalar-value for &special-immediate change.
      Delegate branch on $values to a primcall to `false?'.
---
 module/language/cps/type-fold.scm |  59 +++++++----
 module/language/cps/types.scm     | 201 ++++++++++++++++++++++----------------
 2 files changed, 157 insertions(+), 103 deletions(-)

diff --git a/module/language/cps/type-fold.scm 
b/module/language/cps/type-fold.scm
index b59253e..af20a3d 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -41,7 +41,7 @@
 ;; Branch folders.
 
 (define &scalar-types
-  (logior &fixnum &bignum &flonum &char &unspecified &false &true &nil &null))
+  (logior &fixnum &bignum &flonum &char &special-immediate))
 
 (define *branch-folders* (make-hash-table))
 
@@ -59,6 +59,29 @@
                       body ...)
   (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body 
...)))
 
+(define-syntax-rule (define-special-immediate-predicate-folder name imin imax)
+  (define-unary-branch-folder (name type min max)
+    (let ((type* (logand type &special-immediate)))
+      (cond
+       ((zero? (logand type &special-immediate)) (values #t #f))
+       ((eqv? type &special-immediate)
+        (cond
+         ((or (< imax min) (< max imin)) (values #t #f))
+         ((<= imin min max imax) (values #t #t))
+         (else (values #f #f))))
+       (else (values #f #f))))))
+
+(define-special-immediate-predicate-folder eq-nil? &nil &nil)
+(define-special-immediate-predicate-folder eq-eol? &null &null)
+(define-special-immediate-predicate-folder eq-false? &false &false)
+(define-special-immediate-predicate-folder eq-true? &true &true)
+(define-special-immediate-predicate-folder unspecified? &unspecified 
&unspecified)
+(define-special-immediate-predicate-folder undefined? &undefined &undefined)
+(define-special-immediate-predicate-folder eof-object? &eof &eof)
+(define-special-immediate-predicate-folder null? &null &nil)
+(define-special-immediate-predicate-folder false? &nil &false)
+(define-special-immediate-predicate-folder nil? &null &false) ;; &nil in middle
+
 (define-syntax-rule (define-unary-type-predicate-folder name &type)
   (define-unary-branch-folder (name type min max)
     (let ((type* (logand type &type)))
@@ -69,8 +92,6 @@
 
 ;; All the cases that are in compile-bytecode.
 (define-unary-type-predicate-folder pair? &pair)
-(define-unary-type-predicate-folder null? &null)
-(define-unary-type-predicate-folder nil? &nil)
 (define-unary-type-predicate-folder symbol? &symbol)
 (define-unary-type-predicate-folder variable? &box)
 (define-unary-type-predicate-folder vector? &vector)
@@ -309,11 +330,16 @@
      ((eqv? type &bignum) val)
      ((eqv? type &flonum) (exact->inexact val))
      ((eqv? type &char) (integer->char val))
-     ((eqv? type &unspecified) *unspecified*)
-     ((eqv? type &false) #f)
-     ((eqv? type &true) #t)
-     ((eqv? type &nil) #nil)
-     ((eqv? type &null) '())
+     ((eqv? type &special-immediate)
+      (cond
+       ((eqv? val &null) '())
+       ((eqv? val &nil) #nil)
+       ((eqv? val &false) #f)
+       ((eqv? val &true) #t)
+       ((eqv? val &unspecified) *unspecified*)
+       ;; FIXME: &undefined here
+       ((eqv? val &eof) the-eof-object)
+       (else (error "unhandled immediate" val))))
      (else (error "unhandled type" type val))))
   (let ((types (infer-types cps start)))
     (define (fold-primcall cps label names vars k src name args def)
@@ -416,19 +442,10 @@
             (or (fold-binary-branch cps label names vars k kt src name x y)
                 cps))))
         (($ $branch kt ($ $values (arg)))
-         ;; We might be able to fold branches on values.
-         (call-with-values (lambda () (lookup-pre-type types label arg))
-           (lambda (type min max)
-             (cond
-              ((zero? (logand type (logior &false &nil)))
-               (with-cps cps
-                 (setk label
-                       ($kargs names vars ($continue kt src ($values ()))))))
-              ((zero? (logand type (lognot (logior &false &nil))))
-               (with-cps cps
-                 (setk label
-                       ($kargs names vars ($continue k src ($values ()))))))
-              (else cps)))))
+         ;; We might be able to fold a branch on the false? primcall.
+         ;; Note inverted true and false continuations.
+         (or (fold-unary-branch cps label names vars kt k src 'false? arg)
+             cps))
         (_ cps)))
     (let lp ((label start) (cps cps))
       (if (<= label end)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index b71bd39..2217daa 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -93,17 +93,10 @@
             &fraction
 
             &char
-            &unspecified
-            &unbound
-            &false
-            &true
-            &nil
-            &null
+            &special-immediate
             &symbol
             &keyword
-
             &procedure
-
             &pointer
             &fluid
             &pair
@@ -115,6 +108,10 @@
             &bitvector
             &array
             &syntax
+            &other-heap-object
+
+            ;; Special immediate values.
+            &null &nil &false &true &unspecified &undefined &eof
 
             ;; Union types.
             &exact-integer &number &real
@@ -155,17 +152,11 @@
   &fraction
 
   &char
-  &unspecified
-  &unbound
-  &false
-  &true
-  &nil
-  &null
+  &special-immediate
+
   &symbol
   &keyword
-
   &procedure
-
   &pointer
   &fluid
   &pair
@@ -177,6 +168,7 @@
   &bitvector
   &array
   &syntax
+  &other-heap-object
 
   &f64
   &u64
@@ -184,6 +176,16 @@
 
 (define-syntax &no-type (identifier-syntax 0))
 
+;; Special immediate values.  Note that the values for the first 4 of
+;; these are important; see uses below.
+(define-syntax &null        (identifier-syntax 0))
+(define-syntax &nil         (identifier-syntax 1))
+(define-syntax &false       (identifier-syntax 2))
+(define-syntax &true        (identifier-syntax 3))
+(define-syntax &unspecified (identifier-syntax 4))
+(define-syntax &undefined   (identifier-syntax 5))
+(define-syntax &eof         (identifier-syntax 6))
+
 (define-syntax &exact-integer
   (identifier-syntax (logior &fixnum &bignum)))
 (define-syntax &number
@@ -350,12 +352,12 @@ minimum, and maximum."
            (if (rational? val) (inexact->exact (floor val)) val)
            (if (rational? val) (inexact->exact (ceiling val)) val))))
      (else (return &complex #f))))
-   ((eq? val '()) (return &null #f))
-   ((eq? val #nil) (return &nil #f))
-   ((eq? val #t) (return &true #f))
-   ((eq? val #f) (return &false #f))
+   ((eq? val '()) (return &special-immediate &null))
+   ((eq? val #nil) (return &special-immediate &nil))
+   ((eq? val #t) (return &special-immediate &true))
+   ((eq? val #f) (return &special-immediate &false))
+   ((eqv? val *unspecified*) (return &special-immediate &unspecified))
    ((char? val) (return &char (char->integer val)))
-   ((eqv? val *unspecified*) (return &unspecified #f))
    ((symbol? val) (return &symbol #f))
    ((keyword? val) (return &keyword #f))
    ((pair? val) (return &pair #f))
@@ -365,7 +367,8 @@ minimum, and maximum."
    ((bitvector? val) (return &bitvector (bitvector-length val)))
    ((array? val) (return &array (array-rank val)))
    ((syntax? val) (return &syntax 0))
-   ((not (variable-bound? (make-variable val))) (return &unbound #f))
+   ((not (variable-bound? (make-variable val)))
+    (return &special-immediate &undefined))
 
    (else (error "unhandled constant" val))))
 
@@ -540,15 +543,58 @@ minimum, and maximum."
 ;;; Generic effect-free predicates.
 ;;;
 
-(define-predicate-inferrer (eq? a b true?)
-  ;; We can only propagate information down the true leg.
-  (when true?
-    (let ((type (logand (&type a) (&type b)))
-          (min (max (&min a) (&min b)))
-          (max (min (&max a) (&max b))))
-      (restrict! a type min max)
-      (restrict! b type min max))))
-(define-type-inferrer-aliases eq? eqv?)
+(define-syntax-rule (define-special-immediate-predicate-inferrer pred imm*)
+  (define-predicate-inferrer (pred val true?)
+    (let ((imm imm*))
+      (define (range-subtract lo hi x)
+        (values (if (eqv? lo x) (1+ lo) lo)
+                (if (eqv? hi x) (1- hi) hi)))
+      (cond
+       (true? (restrict! val &special-immediate imm imm))
+       (else
+        (when (eqv? (&type val) &special-immediate)
+          (let-values (((lo hi) (range-subtract (&min val) (&max val) imm)))
+            (restrict! val &special-immediate lo hi))))))))
+
+(define-special-immediate-predicate-inferrer eq-nil? &nil)
+(define-special-immediate-predicate-inferrer eq-eol? &null)
+(define-special-immediate-predicate-inferrer eq-false? &false)
+(define-special-immediate-predicate-inferrer eq-true? &true)
+(define-special-immediate-predicate-inferrer unspecified? &unspecified)
+(define-special-immediate-predicate-inferrer undefined? &undefined)
+(define-special-immediate-predicate-inferrer eof-object? &eof)
+
+;; Various inferrers rely on these having contiguous values starting from 0.
+(eval-when (expand)
+  (unless (< -1 &null &nil &false &true 4)
+    (error "unexpected special immediate values")))
+(define-predicate-inferrer (null? val true?)
+  (cond
+   (true? (restrict! val &special-immediate &null &nil))
+   (else
+    (when (eqv? (&type val) &special-immediate)
+      (restrict! val &special-immediate (1+ &nil) +inf.0)))))
+
+(define-predicate-inferrer (false? val true?)
+  (cond
+   (true? (restrict! val &special-immediate &nil &false))
+   (else
+    (when (and (eqv? (&type val) &special-immediate) (> (&min val) &null))
+      (restrict! val &special-immediate (1+ &false) +inf.0)))))
+
+(define-predicate-inferrer (nil? val true?)
+  (cond
+   (true? (restrict! val &special-immediate &null &false))
+   (else
+    (when (eqv? (&type val) &special-immediate)
+      (restrict! val &special-immediate (1+ &false) +inf.0)))))
+
+(define-predicate-inferrer (heap-object? val true?)
+  (define &immediate-types
+    (logior &fixnum &char &special-immediate))
+  (define &heap-object-types
+    (logand &all-types (lognot &immediate-types)))
+  (restrict! val (if true? &heap-object-types &immediate-types) -inf.0 +inf.0))
 
 (define-syntax-rule (define-simple-predicate-inferrer predicate type)
   (define-predicate-inferrer (predicate val true?)
@@ -556,9 +602,8 @@ minimum, and maximum."
                     type
                     (logand (&type val) (lognot type)))))
       (restrict! val type -inf.0 +inf.0))))
+
 (define-simple-predicate-inferrer pair? &pair)
-(define-simple-predicate-inferrer null? &null)
-(define-simple-predicate-inferrer nil? &nil)
 (define-simple-predicate-inferrer symbol? &symbol)
 (define-simple-predicate-inferrer variable? &box)
 (define-simple-predicate-inferrer vector? &vector)
@@ -572,6 +617,16 @@ minimum, and maximum."
 (define-simple-predicate-inferrer procedure? &procedure)
 (define-simple-predicate-inferrer thunk? &procedure)
 
+(define-predicate-inferrer (eq? a b true?)
+  ;; We can only propagate information down the true leg.
+  (when true?
+    (let ((type (logand (&type a) (&type b)))
+          (min (max (&min a) (&min b)))
+          (max (min (&max a) (&max b))))
+      (restrict! a type min max)
+      (restrict! b type min max))))
+(define-type-inferrer-aliases eq? eqv?)
+
 
 
 ;;;
@@ -747,7 +802,7 @@ minimum, and maximum."
 
 (define-simple-type (number->string &number) (&string 0 *max-size-t*))
 (define-simple-type (string->number (&string 0 *max-size-t*))
-  ((logior &number &false) -inf.0 +inf.0))
+  ((logior &number &special-immediate) -inf.0 +inf.0))
 
 
 
@@ -1194,46 +1249,33 @@ minimum, and maximum."
       (define-exact-integer! result 0 max-abs-mod)))))
 
 ;; Predicates.
-(define-syntax-rule (define-number-kind-predicate-inferrer name type)
+(define-syntax-rule (define-type-predicate-result val result type)
+  (cond
+   ((zero? (logand (&type val) type))
+    (define! result &special-immediate &false &false))
+   ((zero? (logand (&type val) (lognot type)))
+    (define! result &special-immediate &true &true))
+   (else
+    (define! result &special-immediate &false &true))))
+;; Bah, needs rewrite to turn into actual control flow.
+(define-syntax-rule (define-simple-type-predicate-inferrer name type)
   (define-type-inferrer (name val result)
-    (cond
-     ((zero? (logand (&type val) type))
-      (define! result &false 0 0))
-     ((zero? (logand (&type val) (lognot type)))
-      (define! result &true 0 0))
-     (else
-      (define! result (logior &true &false) 0 0)))))
-(define-number-kind-predicate-inferrer complex? &number)
-(define-number-kind-predicate-inferrer real? &real)
-(define-number-kind-predicate-inferrer rational?
-  (logior &exact-integer &fraction))
-(define-number-kind-predicate-inferrer integer?
-  (logior &exact-integer &flonum))
-(define-number-kind-predicate-inferrer exact-integer?
-  &exact-integer)
+    (define-type-predicate-result val result type)))
+(define-simple-type-predicate-inferrer complex? &number)
+(define-simple-type-predicate-inferrer real? &real)
+(define-simple-type-predicate-inferrer rational? (logior &exact-integer 
&fraction))
+(define-simple-type-predicate-inferrer integer? (logior &exact-integer 
&flonum))
+(define-simple-type-predicate-inferrer exact-integer? &exact-integer)
 
 (define-simple-type-checker (exact? &number))
 (define-type-inferrer (exact? val result)
   (restrict! val &number -inf.0 +inf.0)
-  (cond
-   ((zero? (logand (&type val) (logior &exact-integer &fraction)))
-    (define! result &false 0 0))
-   ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction))))
-    (define! result &true 0 0))
-   (else
-    (define! result (logior &true &false) 0 0))))
+  (define-type-predicate-result val result (logior &exact-integer &fraction)))
 
 (define-simple-type-checker (inexact? &number))
 (define-type-inferrer (inexact? val result)
   (restrict! val &number -inf.0 +inf.0)
-  (cond
-   ((zero? (logand (&type val) (logior &flonum &complex)))
-    (define! result &false 0 0))
-   ((zero? (logand (&type val) (logand &number
-                                       (lognot (logior &flonum &complex)))))
-    (define! result &true 0 0))
-   (else
-    (define! result (logior &true &false) 0 0))))
+  (define-type-predicate-result val result (logior &flonum &complex)))
 
 (define-simple-type-checker (inf? &real))
 (define-type-inferrer (inf? val result)
@@ -1241,14 +1283,14 @@ minimum, and maximum."
   (cond
    ((or (zero? (logand (&type val) (logior &flonum &complex)))
         (and (not (inf? (&min val))) (not (inf? (&max val)))))
-    (define! result &false 0 0))
+    (define! result &special-immediate &false &false))
    (else
-    (define! result (logior &true &false) 0 0))))
+    (define! result &special-immediate &false &true))))
 
 (define-type-aliases inf? nan?)
 
 (define-simple-type (even? &exact-integer)
-  ((logior &true &false) 0 0))
+  (&special-immediate &false &true))
 (define-type-aliases even? odd?)
 
 ;; Bit operations.
@@ -1413,9 +1455,9 @@ minimum, and maximum."
         (b-max (&max b)))
     (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min))
              (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min)))
-        (let ((type (if (logbit? a-min b-min) &true &false)))
-          (define! result type 0 0))
-        (define! result (logior &true &false) 0 0))))
+        (let ((bool (if (logbit? a-min b-min) &true &false)))
+          (define! result &special-immediate bool bool))
+        (define! result &special-immediate &false &true))))
 
 ;; Flonums.
 (define-simple-type-checker (sqrt &number))
@@ -1613,17 +1655,12 @@ maximum, where type is a bitset as a fixnum."
         (values (append changed0 changed1) typev)))
     ;; Each of these branches must propagate to its successors.
     (match exp
-      (($ $branch kt ($ $values (arg)))
-       ;; The "normal" continuation is the #f branch.
-       (let ((kf-types (restrict-var types arg
-                                     (make-type-entry (logior &false &nil)
-                                                      0
-                                                      0)))
-             (kt-types (restrict-var types arg
-                                     (make-type-entry
-                                      (logand &all-types 
-                                              (lognot (logior &false &nil)))
-                                      -inf.0 +inf.0))))
+      (($ $branch kt ($ $values args))
+       ;; In the future a branch on $values will be replaced by a
+       ;; primcall to 'false?; manually do that here.  Note that the
+       ;; sense of the test is reversed.
+       (let ((kt-types (infer-primcall types 0 'false? args #f))
+             (kf-types (infer-primcall types 1 'false? args #f)))
          (propagate2 k kf-types kt kt-types)))
       (($ $branch kt ($ $primcall name args))
        ;; The "normal" continuation is the #f branch.



reply via email to

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