[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/08: Add scm-ref, etc instructions for generic heap ob
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/08: Add scm-ref, etc instructions for generic heap object field access |
|
Date: |
Wed, 6 Dec 2017 07:59:41 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 315dd366ee7bcdbfde1c9d70e9dbfe85e54f5326
Author: Andy Wingo <address@hidden>
Date: Tue Dec 5 10:54:12 2017 +0100
Add scm-ref, etc instructions for generic heap object field access
* libguile/vm-engine.c (allocate-words, allocate-words/immediate)
(scm-ref, scm-set!, scm-ref/tag, scm-set!/tag, scm-ref/immediate)
(scm-set!/immediate): New instructions for generic access to fields in
heap objects.
* 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/specialize-primcalls.scm (specialize-primcalls):
* module/language/cps/types.scm (allocate-words)
(allocate-words/immediate, scm-ref, scm-ref/immediate, scm-ref/tag)
(scm-set!/tag, scm-set!, scm-set!/immediate, word-ref)
(word-ref/immediate, word-set!, word-set!/immediate):
* module/system/vm/assembler.scm:
* module/language/cps/compile-bytecode.scm (compile-function): Add
support for the new instructions.
---
libguile/vm-engine.c | 149 ++++++++++++++++++++++++---
module/language/cps/compile-bytecode.scm | 41 ++++++++
module/language/cps/cse.scm | 6 ++
module/language/cps/effects-analysis.scm | 42 ++++++++
module/language/cps/reify-primitives.scm | 45 ++++++++
module/language/cps/specialize-primcalls.scm | 13 ++-
module/language/cps/types.scm | 60 +++++++++++
module/system/vm/assembler.scm | 15 +++
8 files changed, 357 insertions(+), 14 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index e07bf46..43506a6 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1289,18 +1289,143 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
- VM_DEFINE_OP (33, unused_33, NULL, NOP)
- VM_DEFINE_OP (34, unused_34, NULL, NOP)
- VM_DEFINE_OP (35, unused_35, NULL, NOP)
- VM_DEFINE_OP (36, unused_36, NULL, NOP)
- VM_DEFINE_OP (37, unused_37, NULL, NOP)
- VM_DEFINE_OP (38, unused_38, NULL, NOP)
- VM_DEFINE_OP (39, unused_39, NULL, NOP)
- VM_DEFINE_OP (40, unused_40, NULL, NOP)
- VM_DEFINE_OP (41, unused_41, NULL, NOP)
- VM_DEFINE_OP (42, unused_42, NULL, NOP)
- VM_DEFINE_OP (43, unused_43, NULL, NOP)
- VM_DEFINE_OP (44, unused_44, NULL, NOP)
+ VM_DEFINE_OP (33, allocate_words, "allocate-words", OP1 (X8_S12_S12) |
OP_DST)
+ {
+ scm_t_uint16 dst, size;
+
+ UNPACK_12_12 (op, dst, size);
+
+ SYNC_IP ();
+ SP_SET (dst,
+ SCM_PACK_POINTER
+ (scm_inline_gc_malloc_words (thread, SP_REF_U64 (size))));
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (34, allocate_words_immediate, "allocate-words/immediate", OP1
(X8_S12_C12) | OP_DST)
+ {
+ scm_t_uint16 dst, size;
+
+ UNPACK_12_12 (op, dst, size);
+
+ SYNC_IP ();
+ SP_SET (dst,
+ SCM_PACK_POINTER (scm_inline_gc_malloc_words (thread, size)));
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (35, scm_ref, "scm-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ {
+ scm_t_uint8 dst, obj, idx;
+
+ UNPACK_8_8_8 (op, dst, obj, idx);
+
+ SP_SET (dst, SCM_CELL_OBJECT (SP_REF (obj), SP_REF_U64 (idx)));
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (36, scm_set, "scm-set!", OP1 (X8_S8_S8_S8))
+ {
+ scm_t_uint8 obj, idx, val;
+
+ UNPACK_8_8_8 (op, obj, idx, val);
+
+ SCM_SET_CELL_OBJECT (SP_REF (obj), SP_REF_U64 (idx), SP_REF (val));
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (37, scm_ref_tag, "scm-ref/tag", OP1 (X8_S8_S8_C8) | OP_DST)
+ {
+ scm_t_uint8 dst, obj, tag;
+
+ UNPACK_8_8_8 (op, dst, obj, tag);
+
+ SP_SET (dst, SCM_PACK (SCM_CELL_WORD_0 (SP_REF (obj)) - tag));
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (38, scm_set_tag, "scm-set!/tag", OP1 (X8_S8_C8_S8))
+ {
+ scm_t_uint8 obj, tag, val;
+
+ UNPACK_8_8_8 (op, obj, tag, val);
+
+ SCM_SET_CELL_WORD_0 (SP_REF (obj), SCM_UNPACK (SP_REF (val)) + tag);
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (39, scm_ref_immediate, "scm-ref/immediate", OP1 (X8_S8_S8_C8)
| OP_DST)
+ {
+ scm_t_uint8 dst, obj, idx;
+
+ UNPACK_8_8_8 (op, dst, obj, idx);
+
+ SP_SET (dst, SCM_CELL_OBJECT (SP_REF (obj), idx));
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (40, scm_set_immediate, "scm-set!/immediate", OP1 (X8_S8_C8_S8))
+ {
+ scm_t_uint8 obj, idx, val;
+
+ UNPACK_8_8_8 (op, obj, idx, val);
+
+ SCM_SET_CELL_OBJECT (SP_REF (obj), idx, SP_REF (val));
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (41, word_ref, "word-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ {
+ scm_t_uint8 dst, obj, idx;
+
+ UNPACK_8_8_8 (op, dst, obj, idx);
+
+ SP_SET_U64 (dst, SCM_CELL_WORD (SP_REF (obj), SP_REF_U64 (idx)));
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (42, word_set, "word-set!", OP1 (X8_S8_S8_S8))
+ {
+ scm_t_uint8 obj, idx, val;
+
+ UNPACK_8_8_8 (op, obj, idx, val);
+
+ SCM_SET_CELL_WORD (SP_REF (obj), SP_REF_U64 (idx), SP_REF_U64 (val));
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (43, word_ref_immediate, "word-ref/immediate", OP1
(X8_S8_S8_C8) | OP_DST)
+ {
+ scm_t_uint8 dst, obj, idx;
+
+ UNPACK_8_8_8 (op, dst, obj, idx);
+
+ SP_SET_U64 (dst, SCM_CELL_WORD (SP_REF (obj), idx));
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (44, word_set_immediate, "word-set!/immediate", OP1
(X8_S8_C8_S8))
+ {
+ scm_t_uint8 obj, idx, val;
+
+ UNPACK_8_8_8 (op, obj, idx, val);
+
+ SCM_SET_CELL_WORD (SP_REF (obj), idx, SP_REF_U64 (val));
+
+ NEXT (1);
+ }
+
VM_DEFINE_OP (45, unused_45, NULL, NOP)
VM_DEFINE_OP (46, unused_46, NULL, NOP)
VM_DEFINE_OP (47, unused_47, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index b4daf69..a1733d7 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -39,6 +39,7 @@
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (system vm assembler)
+ #:use-module (system base types internal)
#:export (compile-bytecode))
(define (kw-arg-ref args kw default)
@@ -155,6 +156,28 @@
(emit-define! asm (from-sp dst) (from-sp (slot sym))))
(($ $primcall 'resolve (bound?) (name))
(emit-resolve asm (from-sp dst) bound? (from-sp (slot name))))
+ (($ $primcall 'allocate-words annotation (nfields))
+ (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 'scm-ref annotation (obj idx))
+ (emit-scm-ref asm (from-sp dst) (from-sp (slot obj))
+ (from-sp (slot idx))))
+ (($ $primcall 'scm-ref/tag annotation (obj))
+ (let ((tag (match annotation
+ ('pair %tc1-pair)
+ ('struct %tc3-struct))))
+ (emit-scm-ref/tag asm (from-sp dst) (from-sp (slot obj)) tag)))
+ (($ $primcall 'scm-ref/immediate (annotation . idx) (obj))
+ (emit-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
+ (($ $primcall 'word-ref annotation (obj idx))
+ (emit-word-ref asm (from-sp dst) (from-sp (slot obj))
+ (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 'struct-ref/immediate idx (struct))
+ (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
+ idx))
(($ $primcall 'free-ref idx (closure))
(emit-free-ref asm (from-sp dst) (from-sp (slot closure)) idx))
(($ $primcall 'vector-ref #f (vector index))
@@ -312,6 +335,24 @@
(emit-j asm (forward-label khandler-body))))))
(($ $primcall 'cache-current-module! (scope) (mod))
(emit-cache-current-module! asm (from-sp (slot mod)) scope))
+ (($ $primcall 'scm-set! annotation (obj idx val))
+ (emit-scm-set! asm (from-sp (slot obj)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'scm-set!/tag annotation (obj val))
+ (let ((tag (match annotation
+ ('pair %tc1-pair)
+ ('struct %tc3-struct))))
+ (emit-scm-set!/tag asm (from-sp (slot obj)) tag
+ (from-sp (slot val)))))
+ (($ $primcall 'scm-set!/immediate (annotation . idx) (obj val))
+ (emit-scm-set!/immediate asm (from-sp (slot obj)) idx
+ (from-sp (slot val))))
+ (($ $primcall 'word-set! annotation (obj idx val))
+ (emit-word-set! asm (from-sp (slot obj)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'word-set!/immediate (annotation . idx) (obj val))
+ (emit-word-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 bc17bb2..3696745 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -246,6 +246,12 @@ false. It could be that both true and false proofs are
available."
((box-set! #f b o) (o <- box-ref #f b))
((o <- cons #f x y) (x <- car #f o)
(y <- cdr #f o))
+ ((scm-set! p s i x) (x <- scm-ref p s i))
+ ((scm-set!/tag p s x) (x <- scm-ref/tag p s))
+ ((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))
+
((set-car! #f o x) (x <- car #f o))
((set-cdr! #f o y) (y <- cdr #f o))
;; FIXME: how to propagate make-vector/immediate -> vector-length?
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 9b86bec..a2157ec 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -336,6 +336,48 @@ the LABELS that are clobbered by the effects of LABEL."
(define-primitive-effects
((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
+;; Generic objects.
+(define (annotation->memory-kind annotation)
+ ;; FIXME: Flesh this out.
+ (match annotation
+ ('pair &pair)
+ ('vector &vector)))
+
+(define-primitive-effects* param
+ ((allocate-words size) (&allocate (annotation->memory-kind param)))
+ ((allocate-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
+ (annotation->memory-kind param) 0))
+ ((scm-ref/immediate obj) (match param
+ ((ann . idx)
+ (&read-field
+ (annotation->memory-kind ann) idx))))
+ ((scm-set! obj idx val) (&write-object
+ (annotation->memory-kind param)))
+ ((scm-set/tag! obj val) (&write-field
+ (annotation->memory-kind param) 0))
+ ((scm-set!/immediate obj val) (match param
+ ((ann . idx)
+ (&write-field
+ (annotation->memory-kind ann) idx))))
+ ((word-ref obj idx) (&read-object
+ (annotation->memory-kind param)))
+ ((word-ref/immediate obj) (match param
+ ((ann . idx)
+ (&read-field
+ (annotation->memory-kind ann) idx))))
+ ((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)))))
+
;; Pairs.
(define-primitive-effects
((cons a b) (&allocate &pair))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index e5b92e3..dea81b6 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -248,6 +248,51 @@
;; ((ulsh/immediate (u6? y) x) (ulsh x y))
(_
(match (cons name args)
+ (('allocate-words/immediate)
+ (match param
+ ((ann . n)
+ (if (u8? n)
+ cps
+ (with-cps cps
+ (letv n*)
+ (letk kop ($kargs ('n) (n*)
+ ($continue k src
+ ($primcall 'allocate-words ann (n)))))
+ (setk label ($kargs names vars
+ ($continue kop src
+ ($primcall 'load-u64 n ())))))))))
+ (((or 'word-ref/immediate 'scm-ref/immediate) obj)
+ (match param
+ ((ann . idx)
+ (if (u8? idx)
+ cps
+ (let ((op (match name
+ ('word-ref/immediate 'word-ref)
+ ('scm-ref/immediate 'scm-ref))))
+ (with-cps cps
+ (letv idx*)
+ (letk kop ($kargs ('idx) (idx*)
+ ($continue k src
+ ($primcall op ann (obj idx*)))))
+ (setk label ($kargs names vars
+ ($continue kop src
+ ($primcall 'load-u64 idx
()))))))))))
+ (((or 'word-set!/immediate 'scm-set!/immediate) obj val)
+ (match param
+ ((ann . idx)
+ (if (u8? idx)
+ cps
+ (let ((op (match name
+ ('word-set!/immediate 'word-set!)
+ ('scm-set!/immediate 'scm-set!))))
+ (with-cps cps
+ (letv idx*)
+ (letk kop ($kargs ('idx) (idx*)
+ ($continue k src
+ ($primcall op ann (obj idx*)))))
+ (setk label ($kargs names vars
+ ($continue kop src
+ ($primcall 'load-u64 idx
()))))))))))
(((or 'sadd 'ssub 'smul) a b)
(let ((op (match name
('sadd 'uadd) ('ssub 'usub) ('smul 'umul))))
diff --git a/module/language/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
index 25c7d65..a5f1aee 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -107,11 +107,15 @@
(define (specialize-primcall name param args)
(define (rename name)
(build-exp ($primcall name param args)))
+ (define-syntax compute-constant
+ (syntax-rules (->)
+ ((_ (c -> exp) body)
+ (let* ((c (intmap-ref constants c)) (c exp)) body))
+ ((_ c body) (compute-constant (c -> c) body))))
(define-syntax-rule (specialize-case (pat (op c (arg ...))) ...)
(match (cons name args)
(pat
- (let ((c (intmap-ref constants c)))
- (build-exp ($primcall 'op c (arg ...)))))
+ (compute-constant c (build-exp ($primcall 'op c (arg ...)))))
...
(_ #f)))
(specialize-case
@@ -121,6 +125,11 @@
(('allocate-struct v (? uint? n)) (allocate-struct/immediate n (v)))
(('struct-ref s (? uint? n)) (struct-ref/immediate n (s)))
(('struct-set! s (? uint? n) x) (struct-set!/immediate n (s x)))
+ (('allocate-words (? uint? n)) (allocate-words/immediate (n -> (cons
param n)) ()))
+ (('scm-ref o (? uint? i)) (scm-ref/immediate (i -> (cons param i))
(o)))
+ (('scm-set! o (? uint? i) x) (scm-set!/immediate (i -> (cons param i))
(o x)))
+ (('word-ref o (? uint? i)) (word-ref/immediate (i -> (cons param i))
(o)))
+ (('word-set! o (? uint? i) x) (word-set!/immediate (i -> (cons param
i)) (o x)))
(('add x (? num? y)) (add/immediate y (x)))
(('add (? num? y) x) (add/immediate y (x)))
(('sub x (? num? y)) (sub/immediate y (x)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 5c213fc..efe86be 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -706,6 +706,66 @@ minimum, and maximum."
;;;
+;;; Memory.
+;;;
+
+(define (annotation->type ann)
+ ;; Expand me!
+ (match ann
+ ('vector &vector)))
+
+(define-type-inferrer/param (allocate-words param size result)
+ (define! result (annotation->type param) (&min/0 size) (&max/scm-size size)))
+
+(define-type-inferrer/param (allocate-words/immediate param result)
+ (match param
+ ((annotation . size)
+ (define! result (annotation->type annotation) size size))))
+
+(define-type-inferrer/param (scm-ref param obj idx result)
+ (restrict! obj (annotation->type param)
+ (1+ (&min/0 idx)) (target-max-size-t/scm))
+ (define! result &all-types -inf.0 +inf.0))
+
+(define-type-inferrer/param (scm-ref/immediate param obj result)
+ (match param
+ ((annotation . idx)
+ (restrict! obj (annotation->type annotation) (1+ idx) +inf.0)
+ (define! result &all-types -inf.0 +inf.0))))
+
+(define-simple-type-inferrer (scm-ref/tag &pair) &all-types)
+(define-simple-type-inferrer (scm-set!/tag &pair &all-types))
+
+(define-type-inferrer/param (scm-set! param obj idx val)
+ (restrict! obj (annotation->type param) (1+ (&min/0 idx)) +inf.0))
+
+(define-type-inferrer/param (scm-set!/immediate param obj val)
+ (match param
+ ((annotation . idx)
+ (restrict! obj (annotation->type annotation) (1+ idx) +inf.0))))
+
+(define-type-inferrer/param (word-ref param obj idx result)
+ (restrict! obj (annotation->type param)
+ (1+ (&min/0 idx)) (target-max-size-t/scm))
+ (define! result &u64 0 &u64-max))
+
+(define-type-inferrer/param (word-ref/immediate param obj result)
+ (match param
+ ((annotation . idx)
+ (restrict! obj (annotation->type annotation) (1+ idx) +inf.0)
+ (define! result &u64 0 &u64-max))))
+
+(define-type-inferrer/param (word-set! param obj idx word)
+ (restrict! obj (annotation->type param) (1+ (&min/0 idx)) +inf.0))
+
+(define-type-inferrer/param (word-set!/immediate param obj word)
+ (match param
+ ((annotation . idx)
+ (restrict! obj (annotation->type annotation) (1+ idx) +inf.0))))
+
+
+
+;;;
;;; Fluids. Note that we can't track bound-ness of fluids, as pop-fluid
;;; can change boundness.
;;;
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 6a5b748..8b17ae2 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -138,6 +138,21 @@
emit-complex?
emit-fraction?
+ emit-allocate-words
+ emit-allocate-words/immediate
+
+ emit-scm-ref
+ emit-scm-set!
+ emit-scm-ref/tag
+ emit-scm-set!/tag
+ emit-scm-ref/immediate
+ emit-scm-set!/immediate
+
+ emit-word-ref
+ emit-word-set!
+ emit-word-ref/immediate
+ emit-word-set!/immediate
+
emit-call
emit-call-label
emit-tail-call
- [Guile-commits] branch master updated (64acf24 -> da7144d), Andy Wingo, 2017/12/06
- [Guile-commits] 01/08: Bailouts can continue directly to tail, Andy Wingo, 2017/12/06
- [Guile-commits] 03/08: CPS conversion residualizes undefined? predicate, Andy Wingo, 2017/12/06
- [Guile-commits] 04/08: Re-mark "throw" et al as not having fallthrough, Andy Wingo, 2017/12/06
- [Guile-commits] 05/08: Assignment conversion uses unchecked memory accessors, Andy Wingo, 2017/12/06
- [Guile-commits] 06/08: Fix DCE over primcall setters with params, Andy Wingo, 2017/12/06
- [Guile-commits] 02/08: Add scm-ref, etc instructions for generic heap object field access,
Andy Wingo <=
- [Guile-commits] 07/08: Support closure annotations to scm-ref et al, Andy Wingo, 2017/12/06
- [Guile-commits] 08/08: Use unchecked scm-ref/set in closure conversion, Andy Wingo, 2017/12/06