[Guile-commits] branch master updated: Tree-IL-to-CPS compiler delays calls to 'target-most-positive-fixnum'.

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script.

civodul pushed a commit to branch master
in repository guile.

The following commit(s) were added to refs/heads/master by this push:
     new a0b9d86  Tree-IL-to-CPS compiler delays calls to 
'target-most-positive-fixnum'.
a0b9d86 is described below

commit a0b9d866380b04aff27dcbcf1e13051f3d9685ad
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Jun 19 15:06:42 2020 +0200

    Tree-IL-to-CPS compiler delays calls to 'target-most-positive-fixnum'.
    
    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 cb8cabe85f535542ac4fcb165d89722500e42653.
    
    * 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.
---
 .dir-locals.el                          |  1 +
 module/language/tree-il/compile-cps.scm | 63 +++++++++++++++------------------
 2 files changed, 29 insertions(+), 35 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 14c5d6d..26e4ff9 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -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))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index bd2bd77..334b4ce 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-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))