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

Assignment conversion uses unchecked memory accessors

Browse source 
* module/language/cps/effects-analysis.scm (annotation->memory-kind):
  Add box type annotation.
* module/language/cps/reify-primitives.scm (primitive-ref): Reify
  scm-ref/immediate instead of box-ref.
* module/language/cps/specialize-primcalls.scm (specialize-primcalls):
  Remove needless and unbound -> literal.
* module/language/cps/types.scm (annotation->type): Add box type.
* module/language/tree-il/compile-cps.scm (convert): Reify
  scm-ref/immediate / scm-set!/immediate instead of box-ref / box-set!.
This commit is contained in:
Andy Wingo 2017-12-06 11:26:03 +01:00
parent dd8bf6a98c
commit eed4e09723
5 changed files with 32 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -341,7 +341,8 @@ the LABELS that are clobbered by the effects of LABEL."
;; FIXME: Flesh this out.
(match annotation
('pair &pair)
('vector &vector)))
('vector &vector)
('box &box)))
(define-primitive-effects* param
((allocate-words size) (&allocate (annotation->memory-kind param)))

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

@ -91,7 +91,8 @@
(lambda (cps box)
(with-cps cps
(build-term
($continue k src ($primcall 'box-ref #f (box))))))))
($continue k src
($primcall 'scm-ref/immediate '(box . 1) (box))))))))
(define (builtin-ref cps idx k src)
(with-cps cps
@ -257,7 +258,7 @@
(letv n*)
(letk kop ($kargs ('n) (n*)
($continue k src
($primcall 'allocate-words ann (n)))))
($primcall 'allocate-words ann (n*)))))
(setk label ($kargs names vars
($continue kop src
($primcall 'load-u64 n ())))))))))

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

@ -108,10 +108,10 @@
(define (rename name)
(build-exp ($primcall name param args)))
(define-syntax compute-constant
(syntax-rules (->)
((_ (c -> exp) body)
(syntax-rules ()
((_ (c exp) body)
(let* ((c (intmap-ref constants c)) (c exp)) body))
((_ c body) (compute-constant (c -> c) body))))
((_ c body) (compute-constant (c c) body))))
(define-syntax-rule (specialize-case (pat (op c (arg ...))) ...)
(match (cons name args)
(pat
@ -125,11 +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)))
(('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)))

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

@ -712,7 +712,8 @@ minimum, and maximum."
(define (annotation->type ann)
;; Expand me!
(match ann
('vector &vector)))
('vector &vector)
('box &box)))
(define-type-inferrer/param (allocate-words param size result)
(define! result (annotation->type param) (&min/0 size) (&max/scm-size size)))

25
module/language/tree-il/compile-cps.scm
View file

@ -360,7 +360,8 @@
(letv unboxed)
(let$ body (k unboxed))
(letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
(build-term ($continue kunboxed src ($primcall 'box-ref #f (box))))))
(build-term ($continue kunboxed src
($primcall 'scm-ref/immediate '(box . 1) (box))))))
((orig-var subst-var #f) (k cps subst-var))
(var (k cps var))))
((? single-valued?)
@ -411,7 +412,8 @@
(with-cps cps
(let$ k (adapt-arity k src 1))
(rewrite-term (hashq-ref subst sym)
((orig-var box #t) ($continue k src ($primcall 'box-ref #f (box))))
((orig-var box #t) ($continue k src
($primcall 'scm-ref/immediate '(box . 1) (box))))
((orig-var subst-var #f) ($continue k src ($values (subst-var))))
(var ($continue k src ($values (var)))))))
@ -491,7 +493,8 @@
(lambda (cps box)
(with-cps cps
(let$ k (adapt-arity k src 1))
(build-term ($continue k src ($primcall 'box-ref #f (box))))))))
(build-term ($continue k src
($primcall 'scm-ref/immediate '(box . 1) (box))))))))
(($ <module-set> src mod name public? exp)
(convert-arg cps exp
@ -502,7 +505,8 @@
(with-cps cps
(let$ k (adapt-arity k src 0))
(build-term
($continue k src ($primcall 'box-set! #f (box val))))))))))
($continue k src
($primcall 'scm-set!/immediate '(box . 1) (box val))))))))))
(($ <toplevel-ref> src name)
(toplevel-box
@ -510,7 +514,9 @@
(lambda (cps box)
(with-cps cps
(let$ k (adapt-arity k src 1))
(build-term ($continue k src ($primcall 'box-ref #f (box))))))))
(build-term
($continue k src
($primcall 'scm-ref/immediate '(box . 1) (box))))))))
(($ <toplevel-set> src name exp)
(convert-arg cps exp
@ -521,7 +527,8 @@
(with-cps cps
(let$ k (adapt-arity k src 0))
(build-term
($continue k src ($primcall 'box-set! #f (box val))))))))))
($continue k src
($primcall 'scm-set!/immediate '(box . 1) (box val))))))))))
(($ <toplevel-define> src name exp)
(convert-arg cps exp
@ -530,7 +537,8 @@
(let$ k (adapt-arity k src 0))
(letv box)
(letk kset ($kargs ('box) (box)
($continue k src ($primcall 'box-set! #f (box val)))))
($continue k src
($primcall 'scm-set!/immediate '(box . 1) (box val)))))
($ (with-cps-constants ((name name))
(build-term
($continue kset src ($primcall 'define! #f (name))))))))))
@ -921,7 +929,8 @@
(with-cps cps
(let$ k (adapt-arity k src 0))
(build-term
($continue k src ($primcall 'box-set! #f (box exp))))))))))
($continue k src
($primcall 'scm-set!/immediate '(box . 1) (box exp))))))))))
(($ <seq> src head tail)
(if (zero-valued? head)