summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/cps/compile-bytecode.scm5
-rw-r--r--module/language/cps/cse.scm1
-rw-r--r--module/language/cps/effects-analysis.scm9
-rw-r--r--module/language/cps/reify-primitives.scm1
-rw-r--r--module/language/cps/slot-allocation.scm2
-rw-r--r--module/language/cps/specialize-primcalls.scm2
-rw-r--r--module/language/cps/types.scm11
-rw-r--r--module/system/vm/assembler.scm3
8 files changed, 34 insertions, 0 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index ce4097361..dceab600e 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -170,6 +170,8 @@
(from-sp (slot idx))))
(($ $primcall 'word-ref/immediate (annotation . idx) (obj))
(emit-word-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
+ (($ $primcall 'gc-pointer-ref/immediate (annotation . idx) (obj))
+ (emit-gc-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
(($ $primcall 'struct-ref/immediate idx (struct))
(emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
idx))
@@ -313,6 +315,9 @@
(($ $primcall 'word-set!/immediate (annotation . idx) (obj val))
(emit-word-set!/immediate asm (from-sp (slot obj)) idx
(from-sp (slot val))))
+ (($ $primcall 'gc-pointer-set!/immediate (annotation . idx) (obj val))
+ (emit-gc-pointer-set!/immediate asm (from-sp (slot obj)) idx
+ (from-sp (slot val))))
(($ $primcall 'free-set! idx (closure value))
(emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
idx))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index a7de7a623..5d97e563b 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -256,6 +256,7 @@ false. It could be that both true and false proofs are available."
((scm-set!/immediate p s x) (x <- scm-ref/immediate p s))
((word-set! p s i x) (x <- word-ref p s i))
((word-set!/immediate p s x) (x <- word-ref/immediate p s))
+ ((gc-pointer-set!/immediate p s x) (x <- gc-pointer-ref/immediate p s))
((s <- allocate-struct #f v n) (v <- struct-vtable #f s))
((s <- allocate-struct/immediate n v) (v <- struct-vtable #f s))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 829db4772..b3344ff7a 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -380,6 +380,15 @@ the LABELS that are clobbered by the effects of LABEL."
((word-set!/immediate obj val) (match param
((ann . idx)
(&write-field
+ (annotation->memory-kind ann) idx))))
+ ((gc-pointer-ref/immediate obj) (match param
+ ((ann . idx)
+ (&read-field
+ (annotation->memory-kind ann) idx))))
+ ((gc-pointer-set!/immediate obj val)
+ (match param
+ ((ann . idx)
+ (&write-field
(annotation->memory-kind ann) idx)))))
;; Structs.
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 4580f837e..5cf16c1da 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -337,6 +337,7 @@
(setk label ($kargs names vars
($continue kop src
($primcall 'load-u64 n ())))))))))
+ ;; Assume gc-pointer-ref/immediate is within u8 range.
(((or 'word-ref/immediate 'scm-ref/immediate) obj)
(match param
((ann . idx)
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 3f73a209e..bb6ed53bb 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -765,6 +765,8 @@ are comparable with eqv?. A tmp slot may be used."
'srsh 'srsh/immediate
'bv-s8-ref 'bv-s16-ref 'bv-s32-ref 'bv-s64-ref))
(intmap-add representations var 's64))
+ (($ $primcall (or 'gc-pointer-ref/immediate))
+ (intmap-add representations var 'gcptr))
(_
(intmap-add representations var 'scm))))
(vars
diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm
index 5d578053a..e6c9f32da 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -127,6 +127,8 @@
(('allocate-words (? uint? n)) (allocate-words/immediate n ()))
(('scm-ref o (? uint? i)) (scm-ref/immediate i (o)))
(('scm-set! o (? uint? i) x) (scm-set!/immediate i (o x)))
+ ;; Assume gc-pointer-ref/immediate can always be emitted
+ ;; directly.
(('word-ref o (? uint? i)) (word-ref/immediate i (o)))
(('word-set! o (? uint? i) x) (word-set!/immediate i (o x)))
(('add x (? num? y)) (add/immediate y (x)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 810ad1526..88b2b4268 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -783,6 +783,17 @@ minimum, and maximum."
((annotation . idx)
(restrict! obj (annotation->type annotation) (1+ idx) +inf.0))))
+(define-type-inferrer/param (gc-pointer-ref/immediate param obj result)
+ (match param
+ ((annotation . idx)
+ (restrict! obj (annotation->type annotation) (1+ idx) +inf.0)
+ (define! result &other-heap-object -inf.0 +inf.0))))
+
+(define-type-inferrer/param (gc-pointer-set!/immediate param obj word)
+ (match param
+ ((annotation . idx)
+ (restrict! obj (annotation->type annotation) (1+ idx) +inf.0))))
+
;;;
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 9be3fcfe1..0eb96cdf9 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -155,6 +155,9 @@
emit-word-ref/immediate
emit-word-set!/immediate
+ emit-gc-pointer-ref/immediate
+ emit-gc-pointer-set!/immediate
+
emit-call
emit-call-label
emit-tail-call