From d355b42a3e7d1e314f2bd83d12d9d45e748e19e7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 10 Jan 2018 21:56:30 +0100 Subject: [PATCH] Add optimizer and backend support for gc-pointer-ref * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/cse.scm (compute-equivalent-subexpressions): * module/language/cps/effects-analysis.scm: * module/language/cps/reify-primitives.scm (reify-primitives): * module/language/cps/slot-allocation.scm (compute-var-representations): * module/language/cps/specialize-primcalls.scm (specialize-primcalls): * module/language/cps/types.scm (gc-pointer-ref/immediate): (gc-pointer-set!/immediate): * module/system/vm/assembler.scm: Add support for pointer-ref. --- module/language/cps/compile-bytecode.scm | 5 +++++ module/language/cps/cse.scm | 1 + module/language/cps/effects-analysis.scm | 9 +++++++++ module/language/cps/reify-primitives.scm | 1 + module/language/cps/slot-allocation.scm | 2 ++ module/language/cps/specialize-primcalls.scm | 2 ++ module/language/cps/types.scm | 11 +++++++++++ module/system/vm/assembler.scm | 3 +++ 8 files changed, 34 insertions(+) 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 @@ -378,6 +378,15 @@ the LABELS that are clobbered by the effects of LABEL." ((word-set! obj idx val) (&read-object (annotation->memory-kind param))) ((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))))) 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