summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-11-17 08:48:33 +0100
committerAndy Wingo <wingo@pobox.com>2023-11-17 08:48:33 +0100
commit49aa0940bcd1f77819326e73aaee44f5f359d830 (patch)
treeddbdbfb4a1f33b7f3ff8fef8108046dc162afe0f /module
parentc2a9380a42ed2b2fdcfe641dc912b389f65f8db5 (diff)
downloadguile-49aa0940bcd1f77819326e73aaee44f5f359d830.tar.gz
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.
Diffstat (limited to 'module')
-rw-r--r--module/language/cps/effects-analysis.scm2
-rw-r--r--module/language/cps/guile-vm/lower-primcalls.scm7
-rw-r--r--module/language/cps/switch.scm4
-rw-r--r--module/language/cps/types.scm3
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))