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