[Guile-commits] 07/30: Fix u64/s64 typesafety around fixnum (un)tagging

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit c22e61a7ff5f117afba8f29b60c6ceaf0c142e9d
Author: Andy Wingo <address@hidden>
Date:   Mon Nov 20 19:51:16 2017 +0100

    Fix u64/s64 typesafety around fixnum (un)tagging
    
    * module/language/cps/type-fold.scm (u64->scm, scm->u64): Fix
      type-safety by adding casts.
    * module/language/tree-il/compile-cps.scm (convert, canonicalize):
      Simplify rsh and lsh compilation by not trying to avoid scm->u64 in
      the early stages of the compiler.
---
 module/language/cps/type-fold.scm       | 14 +++++++++++---
 module/language/tree-il/compile-cps.scm | 23 ++++++-----------------
 2 files changed, 17 insertions(+), 20 deletions(-)

diff --git a/module/language/cps/type-fold.scm 
b/module/language/cps/type-fold.scm
index f546cd3..4fbd5c2 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -373,9 +373,13 @@
   (cond
    ((<= max (target-most-positive-fixnum))
     (with-cps cps
+      (letv s64)
+      (letk ks64 ($kargs ('s64) (s64)
+                   ($continue k src
+                     ($primcall 'tag-fixnum #f (s64)))))
       (build-term
-        ($continue k src
-          ($primcall 'tag-fixnum #f (arg))))))
+        ($continue ks64 src
+          ($primcall 'u64->s64 #f (arg))))))
    (else
     (with-cps cps #f))))
 
@@ -405,8 +409,12 @@
    ((and (type<=? type &exact-integer)
          (<= 0 min max (target-most-positive-fixnum)))
     (with-cps cps
+      (letv s64)
+      (letk ks64 ($kargs ('s64) (s64)
+                   ($continue k src
+                     ($primcall 's64->u64 #f (s64)))))
       (build-term
-        ($continue k src
+        ($continue ks64 src
           ($primcall 'untag-fixnum #f (arg))))))
    (else
     (with-cps cps #f))))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 11eed5a..ee6d152 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -664,7 +664,7 @@
                  (match args
                    ((a b)
                     (unbox-arg
-                     cps b 'untag-fixnum
+                     cps b 'scm->u64
                      (lambda (cps b)
                        (have-args cps (list a b)))))))
                 ((make-vector)
@@ -1203,7 +1203,7 @@ integer."
 
        (($ <primcall> src 'ash (a b))
         (match b
-          (($ <const> src2 (? target-fixnum? n))
+          (($ <const> src2 (? exact-integer? n))
            (if (< n 0)
                (make-primcall src 'rsh (list a (make-const src2 (- n))))
                (make-primcall src 'lsh (list a b))))
@@ -1216,21 +1216,10 @@ integer."
               src (list 'a 'b) (list a-sym b-sym) (list a b)
               (make-conditional
                src
-               (make-primcall src 'fixnum? (list b-ref))
-               (make-conditional
-                src
-                (make-primcall src '< (list b-ref (make-const src 0)))
-                (let ((n (make-primcall src '- (list (make-const src 0) 
b-ref))))
-                  (make-primcall src 'rsh (list a-ref n)))
-                (make-primcall src 'lsh (list a-ref b-ref)))
-               (make-primcall
-                src 'throw
-                (list
-                 (make-const #f 'wrong-type-arg)
-                 (make-const #f "ash")
-                 (make-const #f "Wrong type (expecting fixnum): ~S")
-                 (make-primcall #f 'list (list b-ref))
-                 (make-primcall #f 'list (list b-ref))))))))))
+               (make-primcall src '< (list b-ref (make-const src 0)))
+               (let ((n (make-primcall src '- (list (make-const src 0) 
b-ref))))
+                 (make-primcall src 'rsh (list a-ref n)))
+               (make-primcall src 'lsh (list a-ref b-ref))))))))
 
        ;; Eta-convert prompts without inline handlers.
        (($ <prompt> src escape-only? tag body handler)