summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-01-07 13:55:36 +0100
committerAndy Wingo <wingo@pobox.com>2018-01-07 15:42:39 +0100
commitf488bc53e71e5822a5e79632b745cbc8557837a5 (patch)
treea7fc67132b7a8ccc6bc70438b11f29170061cccc
parentc766a883d342dbb498e07963705dbb8869529483 (diff)
downloadguile-f488bc53e71e5822a5e79632b745cbc8557837a5.tar.gz
Instruction explosion for /immediate variants of vector prims
* module/language/tree-il/compile-cps.scm (prepare-vector-access/immediate): New helper. * module/language/tree-il/compile-cps.scm (vector-ref/immediate): (vector-set!/immediate, make-vector/immediate): New expanders.
-rw-r--r--module/language/tree-il/compile-cps.scm91
1 files changed, 88 insertions, 3 deletions
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 7b83ff270..030ed2d5d 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -262,6 +262,29 @@
(lambda (cps pos)
(access cps v pos))))))))
+(define (prepare-vector-access/immediate cps src op v idx access)
+ (unless (and (exact-integer? idx) (<= 0 idx (1- (target-max-vector-length))))
+ (error "precondition failed" idx))
+ (ensure-vector
+ cps src op v
+ (lambda (cps slen)
+ (define out-of-range
+ (vector 'out-of-range
+ (symbol->string op)
+ "Argument 2 out of range: ~S"))
+ (with-cps cps
+ (letv tidx)
+ (letk kthrow
+ ($kargs ('tidx) (tidx)
+ ($throw src 'throw/value+data out-of-range (tidx))))
+ (letk kout-of-range
+ ($kargs () ()
+ ($continue kthrow src ($const idx))))
+ (let$ body (access v (1+ idx)))
+ (letk k ($kargs () () ,body))
+ (build-term
+ ($branch kout-of-range k src 'imm-s64-< idx (slen)))))))
+
(define-primcall-converter vector-length
(lambda (cps k src op param v)
(ensure-vector
@@ -281,6 +304,16 @@
($continue k src
($primcall 'scm-ref 'vector (v upos)))))))))
+(define-primcall-converter vector-ref/immediate
+ (lambda (cps k src op param v)
+ (prepare-vector-access/immediate
+ cps src op v param
+ (lambda (cps v pos)
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($primcall 'scm-ref/immediate `(vector . ,pos) (v)))))))))
+
(define-primcall-converter vector-set!
(lambda (cps k src op param v idx val)
(prepare-vector-access
@@ -291,6 +324,16 @@
($continue k src
($primcall 'scm-set! 'vector (v upos val)))))))))
+(define-primcall-converter vector-set!/immediate
+ (lambda (cps k src op param v val)
+ (prepare-vector-access/immediate
+ cps src op v param
+ (lambda (cps v pos)
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($primcall 'scm-set!/immediate `(vector . ,pos) (v val)))))))))
+
(define-primcall-converter make-vector
(lambda (cps k src op param size init)
(untag-fixnum-in-imm-range
@@ -343,6 +386,42 @@
;; Header word.
($primcall 's64->u64 #f (ssize)))))))))
+(define-primcall-converter make-vector/immediate
+ (lambda (cps k src op param init)
+ (define size param)
+ (define nwords (1+ size))
+ (define (init-fields cps v pos kdone)
+ (if (< 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)
+ (with-cps cps
+ kdone)))
+ (unless (and (exact-integer? size) (<= 0 size (target-max-vector-length)))
+ (error "precondition failed" size))
+ (with-cps cps
+ (letv v w0)
+ (letk kdone
+ ($kargs () ()
+ ($continue k src ($values (v)))))
+ (let$ kinit (init-fields v 1 kdone))
+ (letk ktag1
+ ($kargs ('w0) (w0)
+ ($continue kinit src
+ ($primcall 'word-set!/immediate '(vector . 0) (v w0)))))
+ (letk ktag0
+ ($kargs ('v) (v)
+ ($continue ktag1 src
+ ($primcall 'load-u64 (+ %tc7-vector (ash size 8)) ()))))
+ (build-term
+ ($continue ktag0 src
+ ($primcall 'allocate-words/immediate `(vector . ,nwords) ()))))))
+
(define-primcall-converters
(char->integer scm >u64)
(integer->char u64 >scm)
@@ -957,14 +1036,20 @@
...
(_ def)))
(define (uint? val) (and (exact-integer? val) (<= 0 val)))
+ (define (vector-index? val)
+ (and (exact-integer? val)
+ (<= 0 val (1- (target-max-vector-length)))))
+ (define (vector-size? val)
+ (and (exact-integer? val)
+ (<= 0 val (target-max-vector-length))))
(define (negint? val) (and (exact-integer? val) (< val 0)))
;; FIXME: Add case for mul
(specialize-case
- (('make-vector ($ <const> _ (? uint? n)) init)
+ (('make-vector ($ <const> _ (? vector-size? n)) init)
(make-vector/immediate n (init)))
- (('vector-ref v ($ <const> _ (? uint? n)))
+ (('vector-ref v ($ <const> _ (? vector-index? n)))
(vector-ref/immediate n (v)))
- (('vector-set! v ($ <const> _ (? uint? n)) x)
+ (('vector-set! v ($ <const> _ (? vector-index? n)) x)
(vector-set!/immediate n (v x)))
(('allocate-struct v ($ <const> _ (? uint? n)))
(allocate-struct/immediate n (v)))