summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-08-26 10:19:24 +0200
committerAndy Wingo <wingo@pobox.com>2019-08-26 10:19:24 +0200
commitb02d1b08d7d7f0eaafdd9dcfc3de3a139b25492e (patch)
treeaa592b5ff98f92d9159a52cc662a4ed25c7f9f93 /module
parentb959708114ad88c90cd77a08a9b9dcf6e0d4f446 (diff)
downloadguile-b02d1b08d7d7f0eaafdd9dcfc3de3a139b25492e.tar.gz
Compiler allocates boxed flonums in unmarked space
This fixes a bug whereby the compiler would sometimes allocate floats in marked space. * libguile/gc-inline.h (scm_inline_gc_malloc_pointerless_words): New internal helper. * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): * libguile/intrinsics.c (allocate_pointerless_words): (allocate_pointerless_words_with_freelist): New intrinsics. * libguile/jit.c (compile_allocate_pointerless_words): (compile_allocate_pointerless_words_immediate): New compilers. * libguile/vm-engine.c (allocate_pointerless_words) (allocate_pointerless_words_immediate): New opcodes. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm (param): * module/language/cps/reify-primitives.scm (reify-primitives): * module/language/cps/specialize-primcalls.scm (specialize-primcalls): * module/language/cps/types.scm (allocate-words): (allocate-words/immediate): * module/system/vm/assembler.scm (system): Add support for the new opcodes.
Diffstat (limited to 'module')
-rw-r--r--module/language/cps/compile-bytecode.scm6
-rw-r--r--module/language/cps/effects-analysis.scm7
-rw-r--r--module/language/cps/reify-primitives.scm13
-rw-r--r--module/language/cps/specialize-primcalls.scm2
-rw-r--r--module/language/cps/types.scm4
-rw-r--r--module/system/vm/assembler.scm2
6 files changed, 31 insertions, 3 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index ff593171b..6e7dab8ef 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -162,6 +162,12 @@
(emit-allocate-words asm (from-sp dst) (from-sp (slot nfields))))
(($ $primcall 'allocate-words/immediate (annotation . nfields))
(emit-allocate-words/immediate asm (from-sp dst) nfields))
+ (($ $primcall 'allocate-pointerless-words annotation (nfields))
+ (emit-allocate-pointerless-words asm (from-sp dst)
+ (from-sp (slot nfields))))
+ (($ $primcall 'allocate-pointerless-words/immediate
+ (annotation . nfields))
+ (emit-allocate-pointerless-words/immediate asm (from-sp dst) nfields))
(($ $primcall 'scm-ref annotation (obj idx))
(emit-scm-ref asm (from-sp dst) (from-sp (slot obj))
(from-sp (slot idx))))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index f5d6bb534..03a8feac6 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -363,6 +363,13 @@ the LABELS that are clobbered by the effects of LABEL."
((ann . size)
(&allocate
(annotation->memory-kind ann)))))
+ ((allocate-pointerless-words size)
+ (&allocate (annotation->memory-kind param)))
+ ((allocate-pointerless-words/immediate)
+ (match param
+ ((ann . size)
+ (&allocate
+ (annotation->memory-kind ann)))))
((scm-ref obj idx) (&read-object
(annotation->memory-kind param)))
((scm-ref/tag obj) (&read-field
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 547ea59ee..8165fb2f0 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -416,7 +416,7 @@
($primcall 'load-u64 %tc16-flonum ()))))
(setk label ($kargs names vars
($continue ktag0 src
- ($primcall 'allocate-words/immediate
+ ($primcall 'allocate-pointerless-words/immediate
`(flonum . ,(match (target-word-size)
(4 4)
(8 2)))
@@ -507,7 +507,14 @@
;; ((ulsh/immediate (u6? y) x) (ulsh x y))
(_
(match (cons name args)
- (('allocate-words/immediate)
+ (((or 'allocate-words/immediate
+ 'allocate-pointerless-words/immediate))
+ (define op
+ (match name
+ ('allocate-words/immediate
+ 'allocate-words)
+ ('allocate-pointerless-words/immediate
+ 'allocate-pointerless-words)))
(match param
((ann . n)
(if (u8? n)
@@ -516,7 +523,7 @@
(letv n*)
(letk kop ($kargs ('n) (n*)
($continue k src
- ($primcall 'allocate-words ann (n*)))))
+ ($primcall op ann (n*)))))
(setk label ($kargs names vars
($continue kop src
($primcall 'load-u64 n ())))))))))
diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm
index 51c10a2ff..6410d80ec 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -122,6 +122,8 @@
(_ #f)))
(specialize-case
(('allocate-words (? uint? n)) (allocate-words/immediate n ()))
+ (('allocate-pointerless-words (? uint? n))
+ (allocate-pointerless-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 (tail-)pointer-ref/immediate can always be emitted directly.
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index cf2fe912a..0a06eb0b9 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -742,6 +742,10 @@ minimum, and maximum."
((annotation . size)
(define! result (annotation->type annotation) size size))))
+(define-type-inferrer-aliases allocate-words allocate-pointerless-words)
+(define-type-inferrer-aliases allocate-words/immediate
+ allocate-pointerless-words/immediate)
+
(define-type-inferrer/param (scm-ref param obj idx result)
(restrict! obj (annotation->type param)
(1+ (&min/0 idx)) (target-max-size-t/scm))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index cb4311093..a09e5f600 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -144,6 +144,8 @@
emit-allocate-words
emit-allocate-words/immediate
+ emit-allocate-pointerless-words
+ emit-allocate-pointerless-words/immediate
emit-scm-ref
emit-scm-set!