mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

Fix u64/s64 typesafety around fixnum (un)tagging

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-11-20 19:51:16 +01:00
parent 072188618a
commit c22e61a7ff
2 changed files with 17 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

14
module/language/cps/type-fold.scm
View file

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

23
module/language/tree-il/compile-cps.scm
View file

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