mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-19 19:20:23 +02:00
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.
This commit is contained in:
Andy Wingo
parent
9db628ee29
commit
315dd366ee
8 changed files with 357 additions and 14 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -705,6 +705,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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue