[Guile-commits] 06/08: More precise value representations for bv-contents, $code

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 27669781b7cf2b4aa214519ddeec3123642246da
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Tue Jul 4 15:21:33 2023 +0200

    More precise value representations for bv-contents, $code
    
    * module/language/cps/utils.scm (compute-var-representations): $code
    makes a 'code.  bv-contents makes a 'bv-contents.
    * module/language/cps/slot-allocation.scm:
    * module/language/cps/hoot/tailify.scm:
    * module/system/vm/assembler.scm: Adapt.
---
 module/language/cps/slot-allocation.scm | 8 +++++---
 module/language/cps/utils.scm           | 8 +++++---
 module/system/vm/assembler.scm          | 2 +-
 3 files changed, 11 insertions(+), 7 deletions(-)

diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 8c0c8d44b..78b75e5b9 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -54,7 +54,7 @@
   (slots allocation-slots)
 
   ;; A map of VAR to representation.  A representation is 'scm, 'f64,
-  ;; 'u64, or 's64.
+  ;; 'u64, 's64, 'ptr, 'bv-contents, or 'code.
   ;;
   (representations allocation-representations)
 
@@ -706,8 +706,10 @@ are comparable with eqv?.  A tmp slot may be used."
            (#f slot-map)
            (slot
             (let ((desc (match (intmap-ref representations var)
-                          ((or 'u64 'f64 's64 'ptr) slot-desc-live-raw)
-                          ('scm slot-desc-live-scm))))
+                          ((or 'u64 'f64 's64 'ptr 'bv-contents 'code)
+                           slot-desc-live-raw)
+                          ('scm
+                           slot-desc-live-scm))))
               (logior slot-map (ash desc (* 2 slot)))))))
        live-vars 0))
 
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index fd0650a06..b8fcbce88 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -26,6 +26,7 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (system base target)
   #:use-module (language cps)
   #:use-module (language cps intset)
   #:use-module (language cps intmap)
@@ -418,12 +419,13 @@ by a label, respectively."
                                'srsh 'srsh/immediate
                                's8-ref 's16-ref 's32-ref 's64-ref))
               (intmap-add representations var 's64))
-             (($ $primcall (or 'bv-contents
-                               'pointer-ref/immediate
+             (($ $primcall (or 'pointer-ref/immediate
                                'tail-pointer-ref/immediate))
               (intmap-add representations var 'ptr))
+             (($ $primcall 'bv-contents)
+              (intmap-add representations var 'bv-contents))
              (($ $code)
-              (intmap-add representations var 'ptr))
+              (intmap-add representations var 'code))
              (_
               (intmap-add representations var 'scm))))
           (vars
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 33f3018f6..7e0763e53 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -2587,7 +2587,7 @@ procedure with label @var{rw-init}.  @var{rw-init} may be 
false.  If
                         ((f64) 1)
                         ((u64) 2)
                         ((s64) 3)
-                        ((ptr) 4)
+                        ((ptr code) 4)
                         (else (error "what!" representation)))))
              (put-uleb128 names-port (logior (ash slot 3) tag)))
            (lp definitions))))))