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

Refactor to finish the primcalls-take-parameters work

Browse source 
* module/language/cps/compile-bytecode.scm (compile-function): Remove
  helper to look up constants now that primcalls can take parameters.
* module/language/cps/devirtualize-integers.scm (peel-trace): Remove
  extra argument to expression-effects.
* module/language/cps/effects-analysis.scm (constant?, indexed-field):
  Remove unused definitions.
  (expression-effects): Remove "constants" argument; constants come from
  primcall params.
  (compute-effects): Don't compute a constants table.
* module/language/cps/slot-allocation.scm ($allocation): Remove
  "constant-values" field.
  (lookup-constant-value, lookup-maybe-constant-value): Remove; unused.
  (allocate-slots): Don't create a constants table.
* module/language/cps/specialize-primcalls.scm
  (compute-defining-expressions, compute-constant-values): Move these
  definitions here, which were previously in utils.scm
* module/language/cps/utils.scm: Remove moved definitions.
This commit is contained in:
Andy Wingo 2017-11-21 21:43:27 +01:00
parent 5c9398099d
commit 3600dbf0cc
6 changed files with 76 additions and 115 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -99,9 +99,6 @@
(define (slot sym)
(lookup-slot sym allocation))
(define (constant sym)
(lookup-constant-value sym allocation))
(define (from-sp var)
(- frame-size 1 var))

2
module/language/cps/devirtualize-integers.scm
View file

@ -169,7 +169,7 @@ the trace should be referenced outside of it."
(build-exp ($values ,(rename-uses args))))))
(($ $primcall name param args)
;; exp is effect-free or var of interest in args
(let* ((fx (expression-effects exp #f))
(let* ((fx (expression-effects exp))
(uses-of-interest? (any-use-of-interest? args))
(live-vars (subtract-uses live-vars args)))
;; If the primcall uses a value of interest,

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

@ -208,9 +208,6 @@
(identifier-syntax
(logior &all-effect-kinds (&object &unknown-memory-kinds))))
(define-inlinable (constant? effects)
(zero? effects))
(define-inlinable (causes-effect? x effects)
(not (zero? (logand x effects))))
@ -233,12 +230,6 @@ is or might be a read or a write to the same location as A."
(not (zero? (logand b (logior &read &write))))
(locations-same?)))
(define-inlinable (indexed-field kind var constants)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(if (and (exact-integer? val) (<= 0 val))
(&field kind val)
(&object kind))))
(define *primitive-effects* (make-hash-table))
(define-syntax-rule (define-primitive-effects* param
@ -513,7 +504,7 @@ is or might be a read or a write to the same location as A."
(apply proc param args)
&all-effects)))
(define (expression-effects exp constants)
(define (expression-effects exp)
(match exp
((or ($ $const) ($ $prim) ($ $values))
&no-effects)
@ -529,28 +520,25 @@ is or might be a read or a write to the same location as A."
((or ($ $call) ($ $callk))
&all-effects)
(($ $branch k exp)
(expression-effects exp constants))
(expression-effects exp))
(($ $primcall name param args)
;; FIXME: hack to still support constants table while migrating
;; to immediate parameters.
(primitive-effects (or param constants) name args))))
(primitive-effects param name args))))
(define (compute-effects conts)
(let ((constants (compute-constant-values conts)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names syms ($ $continue k src exp))
(expression-effects exp constants))
(($ $kreceive arity kargs)
(match arity
(($ $arity _ () #f () #f) &type-check)
(($ $arity () () _ () #f) (&allocate &pair))
(($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
(($ $kfun) &type-check)
(($ $kclause) &type-check)
(($ $ktail) &no-effects)))
conts)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names syms ($ $continue k src exp))
(expression-effects exp))
(($ $kreceive arity kargs)
(match arity
(($ $arity _ () #f () #f) &type-check)
(($ $arity () () _ () #f) (&allocate &pair))
(($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
(($ $kfun) &type-check)
(($ $kclause) &type-check)
(($ $ktail) &no-effects)))
conts))
;; There is a way to abuse effects analysis in CSE to also do scalar
;; replacement, effectively adding `car' and `cdr' expressions to `cons'

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

@ -36,16 +36,13 @@
lookup-slot
lookup-maybe-slot
lookup-representation
lookup-constant-value
lookup-maybe-constant-value
lookup-nlocals
lookup-call-proc-slot
lookup-parallel-moves
lookup-slot-map))
(define-record-type $allocation
(make-allocation slots representations constant-values call-allocs
shuffles frame-size)
(make-allocation slots representations call-allocs shuffles frame-size)
allocation?
;; A map of VAR to slot allocation. A slot allocation is an integer,
@ -58,10 +55,6 @@
;;
(representations allocation-representations)
;; A map of VAR to constant value, for variables with constant values.
;;
(constant-values allocation-constant-values)
;; A map of LABEL to /call allocs/, for expressions that continue to
;; $kreceive continuations: non-tail calls and $prompt expressions.
;;
@ -110,20 +103,6 @@
(define *absent* (list 'absent))
(define (lookup-constant-value var allocation)
(let ((value (intmap-ref (allocation-constant-values allocation) var
(lambda (_) *absent*))))
(when (eq? value *absent*)
(error "Variable does not have constant value" var))
value))
(define (lookup-maybe-constant-value var allocation)
(let ((value (intmap-ref (allocation-constant-values allocation) var
(lambda (_) *absent*))))
(if (eq? value *absent*)
(values #f #f)
(values #t value))))
(define (lookup-call-alloc k allocation)
(intmap-ref (allocation-call-allocs allocation) k))
@ -800,7 +779,6 @@ are comparable with eqv?. A tmp slot may be used."
(let*-values (((defs uses) (compute-defs-and-uses cps))
((representations) (compute-var-representations cps))
((live-in live-out) (compute-live-variables cps defs uses))
((constants) (compute-constant-values cps))
((needs-slot) (compute-needs-slot cps defs uses))
((lazy) (compute-lazy-vars cps live-in live-out defs
needs-slot)))
@ -995,5 +973,4 @@ are comparable with eqv?. A tmp slot may be used."
(let* ((slots (allocate-lazy-vars cps slots calls live-in lazy))
(shuffles (compute-shuffles cps slots calls live-in))
(frame-size (compute-frame-size cps slots calls shuffles)))
(make-allocation slots representations constants calls
shuffles frame-size))))))
(make-allocation slots representations calls shuffles frame-size))))))

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

@ -31,6 +31,62 @@
#:use-module (language cps intmap)
#:export (specialize-primcalls))
(define (compute-defining-expressions conts)
(define (meet-defining-expressions old new)
;; If there are multiple definitions and they are different, punt
;; and record #f.
(if (equal? old new)
old
#f))
(persistent-intmap
(intmap-fold (lambda (label cont defs)
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(match (intmap-ref conts k)
(($ $kargs (_) (var))
(intmap-add! defs var exp meet-defining-expressions))
(_ defs)))
(_ defs)))
conts
empty-intmap)))
(define (compute-constant-values conts)
(let ((defs (compute-defining-expressions conts)))
(persistent-intmap
(intmap-fold
(lambda (var exp out)
(match exp
(($ $primcall (or 'load-f64 'load-u64 'load-s64) val ())
(intmap-add! out var val))
;; Punch through type conversions to allow uadd to specialize
;; to uadd/immediate.
(($ $primcall 'scm->f64 #f (val))
(let ((f64 (intmap-ref out val (lambda (_) #f))))
(if (and f64 (number? f64) (inexact? f64) (real? f64))
(intmap-add! out var f64)
out)))
(($ $primcall (or 'scm->u64 'scm->u64/truncate) #f (val))
(let ((u64 (intmap-ref out val (lambda (_) #f))))
(if (and u64 (number? u64) (exact-integer? u64)
(<= 0 u64 #xffffFFFFffffFFFF))
(intmap-add! out var u64)
out)))
(($ $primcall 'scm->s64 #f (val))
(let ((s64 (intmap-ref out val (lambda (_) #f))))
(if (and s64 (number? s64) (exact-integer? s64)
(<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF))
(intmap-add! out var s64)
out)))
(_ out)))
defs
(intmap-fold (lambda (var exp out)
(match exp
(($ $const val)
(intmap-add! out var val))
(_ out)))
defs
empty-intmap)))))
(define (specialize-primcalls conts)
(let ((constants (compute-constant-values conts)))
(define (uint? var)

57
module/language/cps/utils.scm
View file

@ -46,7 +46,6 @@
fixpoint
;; Flow analysis.
compute-constant-values
compute-function-body
compute-reachable-functions
compute-successors
@ -180,62 +179,6 @@ disjoint, an error will be signalled."
(values x0* x1*)
(lp x0* x1*))))))))
(define (compute-defining-expressions conts)
(define (meet-defining-expressions old new)
;; If there are multiple definitions and they are different, punt
;; and record #f.
(if (equal? old new)
old
#f))
(persistent-intmap
(intmap-fold (lambda (label cont defs)
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(match (intmap-ref conts k)
(($ $kargs (_) (var))
(intmap-add! defs var exp meet-defining-expressions))
(_ defs)))
(_ defs)))
conts
empty-intmap)))
(define (compute-constant-values conts)
(let ((defs (compute-defining-expressions conts)))
(persistent-intmap
(intmap-fold
(lambda (var exp out)
(match exp
(($ $primcall (or 'load-f64 'load-u64 'load-s64) val ())
(intmap-add! out var val))
;; Punch through type conversions to allow uadd to specialize
;; to uadd/immediate.
(($ $primcall 'scm->f64 #f (val))
(let ((f64 (intmap-ref out val (lambda (_) #f))))
(if (and f64 (number? f64) (inexact? f64) (real? f64))
(intmap-add! out var f64)
out)))
(($ $primcall (or 'scm->u64 'scm->u64/truncate) #f (val))
(let ((u64 (intmap-ref out val (lambda (_) #f))))
(if (and u64 (number? u64) (exact-integer? u64)
(<= 0 u64 #xffffFFFFffffFFFF))
(intmap-add! out var u64)
out)))
(($ $primcall 'scm->s64 #f (val))
(let ((s64 (intmap-ref out val (lambda (_) #f))))
(if (and s64 (number? s64) (exact-integer? s64)
(<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF))
(intmap-add! out var s64)
out)))
(_ out)))
defs
(intmap-fold (lambda (var exp out)
(match exp
(($ $const val)
(intmap-add! out var val))
(_ out)))
defs
empty-intmap)))))
(define (compute-function-body conts kfun)
(persistent-intset
(let visit-cont ((label kfun) (labels empty-intset))