mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

Improve make-vector compilation for known big sizes

Browse source 
* module/language/tree-il/compile-cps.scm
  (emit-initializations-as-loop): New helper.
  (make-vector): Use new helper.
  (make-vector/immediate): Emit a loop if the number of words is greater
  than or equal to 32.  An arbitrary limit that could be adjusted later.
This commit is contained in:
Andy Wingo 2018-01-07 22:50:55 +01:00
parent 5e1109a97f
commit 55a8483435
1 changed files with 49 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -345,6 +345,25 @@
($continue k src ($continue k src
($primcall 'scm-set!/immediate `(vector . ,pos) (v val))))))) ($primcall 'scm-set!/immediate `(vector . ,pos) (v val)))))))
(define (emit-initializations-as-loop cps k src obj annotation start nwords init)
(with-cps cps
(letv pos)
(letk kloop ,#f) ;; Patched later.
(letk kback
($kargs () ()
($continue kloop src
($primcall 'uadd/immediate 1 (pos)))))
(letk kinit
($kargs () ()
($continue kback src
($primcall 'scm-set! annotation (obj pos init)))))
(setk kloop
($kargs ('pos) (pos)
($branch k kinit src 'u64-< #f (pos nwords))))
(build-term
($continue kloop src
($primcall 'load-u64 start ())))))
(define-primcall-converter allocate-vector (define-primcall-converter allocate-vector
(lambda (cps k src op param) (lambda (cps k src op param)
(define size param) (define size param)
@ -374,26 +393,13 @@
cps src op size 0 (target-max-vector-length) cps src op size 0 (target-max-vector-length)
(lambda (cps ssize) (lambda (cps ssize)
(with-cps cps (with-cps cps
(letv usize nwords v w0-high w0 pos) (letv usize nwords v w0-high w0)
(letk kloop ,#f) ;; Patched later.
(letk kdone (letk kdone
($kargs () () ($kargs () ()
($continue k src ($values (v))))) ($continue k src ($values (v)))))
(letk kback (let$ init-loop
($kargs () () (emit-initializations-as-loop kdone src v 'vector 1 nwords init))
($continue kloop src (letk kbody ($kargs () () ,init-loop))
($primcall 'uadd/immediate 1 (pos)))))
(letk kinit
($kargs () ()
($continue kback src
($primcall 'scm-set! 'vector (v pos init)))))
(setk kloop
($kargs ('pos) (pos)
($branch kinit kdone src 'u64-< #f (usize pos))))
(letk kbody
($kargs () ()
($continue kloop src
($primcall 'load-u64 1 ()))))
(letk ktag2 (letk ktag2
($kargs ('w0) (w0) ($kargs ('w0) (w0)
($continue kbody src ($continue kbody src
@ -425,17 +431,32 @@
(define size param) (define size param)
(define nwords (1+ size)) (define nwords (1+ size))
(define (init-fields cps v pos kdone) (define (init-fields cps v pos kdone)
(if (< pos nwords) ;; Inline the initializations, up to vectors of size 32. Above
(with-cps cps ;; that it's a bit of a waste, so reify a loop instead.
(let$ knext (init-fields v (1+ pos) kdone)) (cond
(letk kinit ((<= 32 nwords)
($kargs () () (with-cps cps
($continue knext src (letv unwords)
($primcall 'scm-set!/immediate `(vector . ,pos) (let$ init-loop
(v init))))) (emit-initializations-as-loop kdone src v 'vector
kinit) pos unwords init))
(with-cps cps (letk kinit ($kargs ('unwords) (unwords) ,init-loop))
kdone))) (letk kusize ($kargs () ()
($continue kinit src
($primcall 'load-u64 nwords ()))))
kusize))
((< pos nwords)
(with-cps cps
(let$ knext (init-fields v (1+ pos) kdone))
(letk kinit
($kargs () ()
($continue knext src
($primcall 'scm-set!/immediate `(vector . ,pos)
(v init)))))
kinit))
(else
(with-cps cps
kdone))))
(unless (and (exact-integer? size) (<= 0 size (target-max-vector-length))) (unless (and (exact-integer? size) (<= 0 size (target-max-vector-length)))
(error "precondition failed" size)) (error "precondition failed" size))
(with-cps cps (with-cps cps