mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

free-ref, free-set take immediate parameters

Browse source 
* module/language/cps/closure-conversion.scm (convert-one):
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/effects-analysis.scm (define-primitive-effects*)
  (expression-effects, primitive-effects): Only fall back to passing
  constant table if the immediate parameter is false.  Adapt closure
  effects analysis.
* module/language/cps/slot-allocation.scm (compute-needs-slot): Remove
  special cases for free-ref/free-set!.
This commit is contained in:
Andy Wingo 2017-11-01 14:29:20 +01:00
parent 6be04684e6
commit 2f45cfcb9c
4 changed files with 21 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

15
module/language/cps/closure-conversion.scm
View file

@ -503,10 +503,9 @@ Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
(letv var*)
(let$ body (k var*))
(letk k* ($kargs (#f) (var*) ,body))
($ (with-cps-constants ((idx idx))
(build-term
($continue k* #f
($primcall 'free-ref #f (self idx)))))))))))))
(build-term
($continue k* #f
($primcall 'free-ref idx (self)))))))))))
(else
(with-cps cps
($ (k var))))))
@ -609,11 +608,9 @@ bound to @var{var}, and continue to @var{k}."
($primcall 'scm->u64 #f (idx))))))))
(else
(with-cps cps
($ (with-cps-constants ((idx idx))
(build-term
($continue k src
($primcall 'free-set! #f
(var idx v)))))))))))))))))))
(build-term
($continue k src
($primcall 'free-set! idx (var v)))))))))))))))))
(define (make-single-closure cps k src kfun)
(let ((free (intmap-ref free-vars kfun)))

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

@ -151,9 +151,8 @@
(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 'free-ref #f (closure idx))
(emit-free-ref asm (from-sp dst) (from-sp (slot closure))
(constant idx)))
(($ $primcall 'free-ref idx (closure))
(emit-free-ref asm (from-sp dst) (from-sp (slot closure)) idx))
(($ $primcall 'vector-ref #f (vector index))
(emit-vector-ref asm (from-sp dst) (from-sp (slot vector))
(from-sp (slot index))))
@ -302,9 +301,9 @@
(emit-j asm (forward-label khandler-body))))))
(($ $primcall 'cache-current-module! (scope) (mod))
(emit-cache-current-module! asm (from-sp (slot mod)) scope))
(($ $primcall 'free-set! #f (closure idx value))
(($ $primcall 'free-set! idx (closure value))
(emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
(constant idx)))
idx))
(($ $primcall 'box-set! #f (box value))
(emit-box-set! asm (from-sp (slot box)) (from-sp (slot value))))
(($ $primcall 'struct-set! #f (struct index value))

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

@ -244,18 +244,18 @@ is or might be a read or a write to the same location as A."
(define *primitive-effects* (make-hash-table))
(define-syntax-rule (define-primitive-effects* constants
(define-syntax-rule (define-primitive-effects* param
((name . args) effects ...)
...)
(begin
(hashq-set! *primitive-effects* 'name
(case-lambda*
((constants . args) (logior effects ...))
((param . args) (logior effects ...))
(_ &all-effects)))
...))
(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
(define-primitive-effects* constants ((name . args) effects ...) ...))
(define-primitive-effects* param ((name . args) effects ...) ...))
;; Miscellaneous.
(define-primitive-effects
@ -415,15 +415,9 @@ is or might be a read or a write to the same location as A."
((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
;; Closures.
(define (closure-field n constants)
(indexed-field &closure n constants))
(define (read-closure-field n constants)
(logior &read (closure-field n constants)))
(define (write-closure-field n constants)
(logior &write (closure-field n constants)))
(define-primitive-effects* constants
((free-ref closure idx) (read-closure-field idx constants))
((free-set! closure idx val) (write-closure-field idx constants)))
(define-primitive-effects* param
((free-ref closure) (&read-field &closure param))
((free-set! closure val) (&write-field &closure param)))
;; Modules.
(define-primitive-effects
@ -515,10 +509,10 @@ is or might be a read or a write to the same location as A."
;; so no need to have a case for them here. (Though, see
;; https://jfbastien.github.io/no-sane-compiler/.)
(define (primitive-effects constants name args)
(define (primitive-effects name param args)
(let ((proc (hashq-ref *primitive-effects* name)))
(if proc
(apply proc constants args)
(apply proc param args)
&all-effects)))
(define (expression-effects exp constants)
@ -539,7 +533,9 @@ is or might be a read or a write to the same location as A."
(($ $branch k exp)
(expression-effects exp constants))
(($ $primcall name param args)
(primitive-effects constants name args))))
;; FIXME: hack to still support constants table while migrating
;; to immediate parameters.
(primitive-effects (or param constants) name args))))
(define (compute-effects conts)
(let ((constants (compute-constant-values conts)))

4
module/language/cps/slot-allocation.scm
View file

@ -335,10 +335,6 @@ the definitions that are live before and after LABEL, as intsets."
empty-intset)
;; FIXME: Move all of these instructions to use $primcall
;; params.
(($ $primcall 'free-ref #f (closure slot))
(defs+ closure))
(($ $primcall 'free-set! #f (closure slot value))
(defs+* (intset closure value)))
(($ $primcall 'make-vector/immediate #f (len init))
(defs+ init))
(($ $primcall 'vector-ref/immediate #f (v i))