mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-19 11:10:25 +02:00
Code Activity

Add scm-ref, etc instructions for generic heap object field access

Browse source 
* 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 2017-12-05 10:54:12 +01:00
parent 9db628ee29
commit 315dd366ee
8 changed files with 357 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

41
module/language/cps/compile-bytecode.scm
View file

@ -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))

6
module/language/cps/cse.scm
View file

@ -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?

42
module/language/cps/effects-analysis.scm
View file

@ -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))

45
module/language/cps/reify-primitives.scm
View file

@ -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))))

13
module/language/cps/specialize-primcalls.scm
View file

@ -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)))

60
module/language/cps/types.scm
View file

@ -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.