This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch main
in repository guile.
The following commit(s) were added to refs/heads/main by this push:
new 49aa0940b Add CPS primcall for symbol-hash
49aa0940b is described below
commit 49aa0940bcd1f77819326e73aaee44f5f359d830
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Fri Nov 17 08:48:33 2023 +0100
Add CPS primcall for symbol-hash
* module/language/cps/effects-analysis.scm: symbol-hash is effect-free.
* module/language/cps/guile-vm/lower-primcalls.scm (symbol-hash): Lower
to word-ref/immediate.
* module/language/cps/switch.scm (optimize-branch-chain): Emit
symbol-hash instead of word-ref/immediate.
* module/language/cps/types.scm (symbol-hash): Infer result.
---
module/language/cps/effects-analysis.scm | 2 ++
module/language/cps/guile-vm/lower-primcalls.scm | 7 +++++++
module/language/cps/switch.scm | 4 ++--
module/language/cps/types.scm | 3 +++
4 files changed, 14 insertions(+), 2 deletions(-)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 7b1e1d0ea..845394de0 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -497,6 +497,8 @@ the LABELS that are clobbered by the effects of LABEL."
((string-ref str idx) (&read-object &string))
((string-set! str idx cp) (&write-object &string))
+ ((symbol-hash))
+
((make-closure code) (&allocate &closure))
((closure-ref code) (match param
((idx . nfree)
diff --git a/module/language/cps/guile-vm/lower-primcalls.scm
b/module/language/cps/guile-vm/lower-primcalls.scm
index ae14f34e0..481721062 100644
--- a/module/language/cps/guile-vm/lower-primcalls.scm
+++ b/module/language/cps/guile-vm/lower-primcalls.scm
@@ -476,6 +476,13 @@
($continue kadd src
($primcall 'word-ref/immediate '(string . 2) (s))))))
+;; precondition: sym is a symbol.
+(define-primcall-lowerer (symbol-hash cps k src #f (sym))
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($primcall 'word-ref/immediate '(symbol . 2) (sym))))))
+
;; precondition: none.
(define-primcall-lowerer (make-atomic-box cps k src #f (val))
(with-cps cps
diff --git a/module/language/cps/switch.scm b/module/language/cps/switch.scm
index c600d11ab..f4ae40567 100644
--- a/module/language/cps/switch.scm
+++ b/module/language/cps/switch.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2020, 2023 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
@@ -371,7 +371,7 @@ object."
(letk khash
($kargs () ()
($continue kidx #f
- ($primcall 'word-ref/immediate '(symbol . 2) (var)))))
+ ($primcall 'symbol-hash #f (var)))))
(letk ksym
($kargs () ()
($branch next khash #f 'symbol? #f (var))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 9816078d4..597654ab8 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -807,6 +807,9 @@ minimum, and maximum."
(define-type-inferrer (string-ref str idx result)
(define! result &u64 0 *max-codepoint*))
+(define-type-inferrer (symbol-hash sym result)
+ (define! result &u64 0 &u64-max))
+
(define-type-inferrer/param (make-closure param code result)
(define nfree param)
(define! result &procedure nfree nfree))
