From 315dd366ee7bcdbfde1c9d70e9dbfe85e54f5326 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 5 Dec 2017 10:54:12 +0100 Subject: [PATCH] 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 e07bf46e5..43506a69c 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 b4daf6999..a1733d7c0 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 bc17bb2cd..3696745c5 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 9b86bec72..a2157ecc1 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 e5b92e3d9..dea81b6bd 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 25c7d659b..a5f1aee77 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 5c213fc5c..efe86be1f 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -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. diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 6a5b7481b..8b17ae2e1 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