mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Tree-IL-to-CPS compiler delays calls to 'target-most-positive-fixnum'.

Browse source 
Fixes a bug whereby, for example, "guild compile --target=i686-linux-gnu"
running on x86_64 would generate invalid code for 'bytevector-u32-native-set!'
because 'target-most-positive-fixnum' was called from the top-level
when (language tree-il compile-cps) was loaded.

Consequently, the .go files under prebuilt/ would be invalid, leading to
build failures on 32-bit platforms.

This issue became apparent with cb8cabe85f.

* module/language/tree-il/compile-cps.scm (bytevector-ref-converter)[tag]:
Turn into a lambda so that 'target-most-positive-fixnum' is called in
the right context.
(bytevector-set-converter)[integer-unboxer]: Likewise.
This commit is contained in:
Ludovic Courtès 2020-06-19 15:06:42 +02:00
parent 1ab2105339
commit a0b9d86638
2 changed files with 29 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -14,6 +14,7 @@
(eval . (put 'with-test-prefix/c&e 'scheme-indent-function 1))
(eval . (put 'with-code-coverage 'scheme-indent-function 1))
(eval . (put 'with-statprof 'scheme-indent-function 1))
(eval . (put 'with-target 'scheme-indent-function 1))
(eval . (put 'let-gensyms 'scheme-indent-function 1))
(eval . (put 'let-fresh 'scheme-indent-function 2))
(eval . (put 'with-fresh-name-state 'scheme-indent-function 1))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2015,2017-2019 Free Software Foundation, Inc.
;; Copyright (C) 2013-2015,2017-2020 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
@ -895,37 +895,32 @@
($ (ensure-bytevector klen src op pred bv))))
(define (bytevector-ref-converter scheme-name ptr-op width kind)
(define tag
(define (tag cps k src val)
(match kind
('unsigned
(if (< (ash 1 (* width 8)) (target-most-positive-fixnum))
(lambda (cps k src val)
(with-cps cps
(letv s)
(letk kcvt
($kargs ('s) (s)
($continue k src ($primcall 'tag-fixnum #f (s)))))
(build-term
($continue kcvt src ($primcall 'u64->s64 #f (val))))))
(lambda (cps k src val)
(with-cps cps
(build-term
($continue k src ($primcall 'u64->scm #f (val))))))))
(with-cps cps
(letv s)
(letk kcvt
($kargs ('s) (s)
($continue k src ($primcall 'tag-fixnum #f (s)))))
(build-term
($continue kcvt src ($primcall 'u64->s64 #f (val)))))
(with-cps cps
(build-term
($continue k src ($primcall 'u64->scm #f (val)))))))
('signed
(if (< (ash 1 (* width 8)) (target-most-positive-fixnum))
(lambda (cps k src val)
(with-cps cps
(build-term
($continue k src ($primcall 'tag-fixnum #f (val))))))
(lambda (cps k src val)
(with-cps cps
(build-term
($continue k src ($primcall 's64->scm #f (val))))))))
(with-cps cps
(build-term
($continue k src ($primcall 'tag-fixnum #f (val)))))
(with-cps cps
(build-term
($continue k src ($primcall 's64->scm #f (val)))))))
('float
(lambda (cps k src val)
(with-cps cps
(build-term
($continue k src ($primcall 'f64->scm #f (val)))))))))
(with-cps cps
(build-term
($continue k src ($primcall 'f64->scm #f (val))))))))
(lambda (cps k src op param bv idx)
(prepare-bytevector-access
cps src scheme-name 'bytevector? bv idx width
@ -962,9 +957,9 @@
(build-term
($branch k' kbad src 'imm-s64-< hi (sval)))))
(define (integer-unboxer lo hi)
(cond
((<= hi (target-most-positive-fixnum))
(lambda (cps src val have-val)
(lambda (cps src val have-val)
(cond
((<= hi (target-most-positive-fixnum))
(let ((have-val (if (zero? lo)
(lambda (cps s)
(with-cps cps
@ -989,17 +984,15 @@
($kargs () ()
($continue klo src ($primcall 'untag-fixnum #f (val)))))
(build-term
($branch kbad kuntag src 'fixnum? #f (val)))))))
((zero? lo)
(lambda (cps src val have-val)
($branch kbad kuntag src 'fixnum? #f (val))))))
((zero? lo)
(with-cps cps
(letv u)
(let$ body (limit-urange src val u hi have-val))
(letk khi ($kargs ('u) (u) ,body))
(build-term
($continue khi src ($primcall 'scm->u64 #f (val)))))))
(else
(lambda (cps src val have-val)
($continue khi src ($primcall 'scm->u64 #f (val))))))
(else
(with-cps cps
(letv s)
(let$ body (limit-srange src val s lo hi have-val))