summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-01-19 21:57:03 +0100
committerAndy Wingo <wingo@pobox.com>2018-01-19 21:57:03 +0100
commit557acdbbba9e3bcc1108d81cbf8c2f7c14fcb29a (patch)
treedf9eb06704d73168960f518cb18de49b2ea320c1
parent310c34e11200db58f59c119d58c65822728ba3ba (diff)
downloadguile-557acdbbba9e3bcc1108d81cbf8c2f7c14fcb29a.tar.gz
Instruction explosion for struct-ref, struct-set!
* module/language/cps/effects-analysis.scm (&memory-kind-mask): Add &bitmask, for the bitmask in vtables. (annotation->memory-kind): Add 'bitmask case. * module/language/tree-il/compile-cps.scm (ensure-struct-index-in-range): (prepare-struct-scm-access): New helpers. (struct-ref/immediate, struct-set!/immediate): New exploded lowering routines. (struct-ref, struct-set!): New lowering routines that just do a call. (canonicalize): Remove struct-ref hack; lowering procedures will handle it. * module/language/tree-il/cps-primitives.scm (bytevector-length): Define struct-set! as returning a value.
-rw-r--r--module/language/cps/effects-analysis.scm6
-rw-r--r--module/language/tree-il/compile-cps.scm132
-rw-r--r--module/language/tree-il/cps-primitives.scm6
3 files changed, 131 insertions, 13 deletions
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index bfa95cb7b..f2066f46e 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -185,7 +185,10 @@
&bytevector
;; Indicates a dependency on a free variable of a closure.
- &closure)
+ &closure
+
+ ;; Indicates a dependency on a raw bitmask, measured in 32-bit units.
+ &bitmask)
(define-inlinable (&field kind field)
(ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
@@ -344,6 +347,7 @@ the LABELS that are clobbered by the effects of LABEL."
('pair &pair)
('vector &vector)
('bytevector &bytevector)
+ ('bitmask &bitmask)
('box &box)
('closure &closure)
('struct &struct)))
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 1593910cf..38d3a7e05 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -646,6 +646,127 @@
(build-term
($continue k src ($values (vtable)))))))))
+(define (ensure-struct-index-in-range cps src op vtable idx boxed? in-range)
+ (define vtable-index-size 5) ; FIXME: pull from struct.h
+ (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h
+ (define vtable-offset-size (1+ vtable-index-size))
+ (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields))
+ (define bad-type
+ (vector
+ 'wrong-type-arg
+ (symbol->string op)
+ (if boxed?
+ "Wrong type argument in position 2 (expecting boxed field): ~S"
+ "Wrong type argument in position 2 (expecting unboxed field): ~S")))
+ (define out-of-range
+ (vector 'out-of-range
+ (symbol->string op)
+ "Argument 2 out of range: ~S"))
+ (with-cps cps
+ (letv rfields nfields ptr word bits mask res throwval1 throwval2)
+ (letk kthrow1
+ ($kargs (#f) (throwval1)
+ ($throw src 'throw/value+data out-of-range (throwval1))))
+ (letk kthrow2
+ ($kargs (#f) (throwval2)
+ ($throw src 'throw/value+data bad-type (throwval2))))
+ (letk kbadidx ($kargs () () ($continue kthrow1 src ($const idx))))
+ (letk kbadtype ($kargs () () ($continue kthrow2 src ($const idx))))
+
+ (let$ body (in-range))
+ (letk k ($kargs () () ,body))
+ (letk ktest
+ ($kargs ('res) (res)
+ ($branch (if boxed? kbadtype k) (if boxed? k kbadtype) src
+ 'u64-imm-= 0 (res))))
+ (letk kand
+ ($kargs ('mask) (mask)
+ ($continue ktest src
+ ($primcall 'ulogand #f (mask bits)))))
+ (letk kbits
+ ($kargs ('bits) (bits)
+ ($continue kand src
+ ($primcall 'load-u64 (ash 1 (logand idx 31)) ()))))
+ (letk kword
+ ($kargs ('word) (word)
+ ($continue kbits src
+ ($primcall 'u32-ref 'bitmask (vtable ptr word)))))
+ (letk kptr
+ ($kargs ('ptr) (ptr)
+ ($continue kword src
+ ($primcall 'load-u64 (ash idx -5) ()))))
+ (letk kaccess
+ ($kargs () ()
+ ($continue kptr src
+ ($primcall 'pointer-ref/immediate
+ `(struct . ,vtable-offset-unboxed-fields)
+ (vtable)))))
+ (letk knfields
+ ($kargs ('nfields) (nfields)
+ ($branch kbadidx kaccess src 'imm-u64-< idx (nfields))))
+ (letk kassume
+ ($kargs ('rfields) (rfields)
+ ($continue knfields src
+ ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (rfields)))))
+ (build-term
+ ($continue kassume src
+ ($primcall 'word-ref/immediate
+ `(struct . ,vtable-offset-size) (vtable))))))
+
+(define (prepare-struct-scm-access cps src op struct idx boxed? have-pos)
+ (define not-struct
+ (vector 'wrong-type-arg
+ (symbol->string op)
+ "Wrong type argument in position 1 (expecting struct): ~S"))
+ (ensure-struct
+ cps src op struct
+ (lambda (cps vtable)
+ (ensure-struct-index-in-range
+ cps src op vtable idx boxed?
+ (lambda (cps) (have-pos cps (1+ idx)))))))
+
+(define-primcall-converter struct-ref/immediate
+ (lambda (cps k src op param struct)
+ (prepare-struct-scm-access
+ cps src op struct param #t
+ (lambda (cps pos)
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($primcall 'scm-ref/immediate `(struct . ,pos) (struct)))))))))
+
+(define-primcall-converter struct-set!/immediate
+ (lambda (cps k src op param struct val)
+ (prepare-struct-scm-access
+ cps src op struct param #t
+ (lambda (cps pos)
+ (with-cps cps
+ (letk k* ($kargs () () ($continue k src ($values (val)))))
+ (build-term
+ ($continue k* src
+ ($primcall 'scm-set!/immediate `(struct . ,pos) (struct val)))))))))
+
+(define-primcall-converter struct-ref
+ (lambda (cps k src op param struct idx)
+ (with-cps cps
+ (letv prim res)
+ (letk krecv ($kreceive '(res) #f k))
+ (letk kprim ($kargs ('prim) (prim)
+ ($continue krecv src ($call prim (struct idx)))))
+ (build-term
+ ($continue kprim src ($prim 'struct-ref))))))
+
+(define-primcall-converter struct-set!
+ (lambda (cps k src op param struct idx val)
+ (with-cps cps
+ (letv prim res)
+ ;; struct-set! prim returns the value.
+ (letk krecv ($kreceive '(res) #f k))
+ (letk kprim ($kargs ('prim) (prim)
+ ($continue krecv src ($call prim (struct idx val)))))
+ (build-term
+ ($continue kprim src ($prim 'struct-set!))))))
+
(define (untag-bytevector-index cps src op idx ulen width have-uidx)
(define not-fixnum
(vector 'wrong-type-arg
@@ -927,7 +1048,6 @@
(string-ref scm u64 >scm) (string-set! scm u64 scm)
(allocate-struct scm u64 >scm)
- (struct-ref scm u64 >scm) (struct-set! scm u64 scm)
(rsh scm u64 >scm)
(lsh scm u64 >scm))
@@ -2030,16 +2150,6 @@ integer."
(const '())
(reverse args)))))
- (($ <primcall> src 'struct-set! (struct index value))
- ;; Unhappily, and undocumentedly, struct-set! returns the value
- ;; that was set. There is code that relies on this. Hackety
- ;; hack...
- (with-lexicals src (value)
- (make-seq src
- (make-primcall src 'struct-set!
- (list struct index value))
- value)))
-
;; Lower (logand x (lognot y)) to (logsub x y). We do it here
;; instead of in CPS because it gets rid of the lognot entirely;
;; if type folding can't prove Y to be an exact integer, then DCE
diff --git a/module/language/tree-il/cps-primitives.scm b/module/language/tree-il/cps-primitives.scm
index 6888ab9f8..be92de6a0 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -104,7 +104,11 @@
(define-cps-primitive struct-vtable 1 1)
(define-cps-primitive allocate-struct 2 1)
(define-cps-primitive struct-ref 2 1)
-(define-cps-primitive struct-set! 3 0)
+
+;; Unhappily, and undocumentedly, struct-set! returns the value that was
+;; set. There is code that relies on this. The struct-set! lowering
+;; routines ensure this return arity.
+(define-cps-primitive struct-set! 3 1)
(define-cps-primitive class-of 1 1)