[Guile-commits] branch wip-tailify updated: Make 'ptr types more precise, pre-lowering

[Andy Wingo]

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

wingo pushed a commit to branch wip-tailify
in repository guile.

The following commit(s) were added to refs/heads/wip-tailify by this push:
     new 34c346737 Make 'ptr types more precise, pre-lowering
34c346737 is described below

commit 34c3467379c616b311bbcf7976bdd62c7e26b84c
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Jul 4 15:21:33 2023 +0200

    Make 'ptr types more precise, pre-lowering
    
    * module/language/cps/utils.scm (compute-var-representations): $code
    makes a 'code.  bv-contents makes a 'raw-bytevector.
    * module/language/cps/slot-allocation.scm:
    * module/language/cps/hoot/tailify.scm:
    * module/system/vm/assembler.scm: Adapt.
---
 module/language/cps/hoot/tailify.scm    | 6 +++---
 module/language/cps/slot-allocation.scm | 8 +++++---
 module/language/cps/utils.scm           | 8 +++++---
 module/system/vm/assembler.scm          | 2 +-
 4 files changed, 14 insertions(+), 10 deletions(-)

diff --git a/module/language/cps/hoot/tailify.scm 
b/module/language/cps/hoot/tailify.scm
index 9d38df6f6..f45e66e2a 100644
--- a/module/language/cps/hoot/tailify.scm
+++ b/module/language/cps/hoot/tailify.scm
@@ -212,7 +212,7 @@ be rewritten to continue to the tail's ktail."
                               ($continue local-ktail src
                                 ($calli args ret))))
                 (build-term ($continue kcall src
-                              ($primcall 'restore '(ptr) ())))))
+                              ($primcall 'restore '(code) ())))))
              ((or ($ $call) ($ $callk) ($ $calli))
               ;; Otherwise the original term was a tail call.
               (with-cps cps
@@ -238,7 +238,7 @@ be rewritten to continue to the tail's ktail."
                     (letk kcont ($kargs ('cont) (cont)
                                   ($continue kexp src
                                     ($primcall 'save
-                                               (append reprs (list 'ptr))
+                                               (append reprs (list 'code))
                                                ,(append vars (list cont))))))
                     (build-term ($continue kcont src
                                   ($code (intmap-ref entries k))))))))
@@ -691,7 +691,7 @@ to tail-call the saved continuation."
                        ($continue k src ($calli args ret))))
          (setk label ($kargs names vars
                        ($continue kcall src
-                         ($primcall 'restore '(ptr) ()))))))
+                         ($primcall 'restore '(code) ()))))))
       (_ cps)))
   (intset-fold rewrite-return-to-pop-and-calli body cps))
 
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 8c0c8d44b..269c98126 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, 'raw-bytevector, 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 'raw-bytevector '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 c7b0dc5ac..2c248cd5f 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,14 +419,15 @@ 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 'raw-bytevector))
              (($ $primcall 'restore (repr) ())
               (intmap-add representations var repr))
              (($ $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 a655e0a55..750d016ce 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -2588,7 +2588,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))))))