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

Make 'ptr types more precise, pre-lowering

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2023-07-04 15:21:33 +02:00
parent 3c83a77da5
commit 34c3467379
4 changed files with 14 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

6
module/language/cps/hoot/tailify.scm
View file

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

8
module/language/cps/slot-allocation.scm
View file

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

8
module/language/cps/utils.scm
View file

@ -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

2
module/system/vm/assembler.scm
View file

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