dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Lower "make-struct/simple" to CPS

Browse source 
* module/language/tree-il/cps-primitives.scm (struct-init!): Add
  primitive, just used in internal translations.
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
  (*primitive-constructors*): Recognize "make-struct/simple" instead of
  allocate-struct.
* module/language/tree-il/compile-cps.scm (ensure-vtable): New helper.
  (allocate-struct, struct-init!): New lowerers.
  (convert): Add struct-init! case.
  (canonicalize): Convert make-struct/simple like vector.
This commit is contained in:
Andy Wingo 2018-01-21 21:44:59 +01:00
commit 91bf9b1db3
3 changed files with 142 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -646,6 +646,114 @@
(build-term
($continue k src ($values (vtable)))))))))
(define (ensure-vtable cps src op vtable is-vtable)
(ensure-struct
cps src op vtable
(lambda (cps vtable-vtable)
(define not-vtable
(vector 'wrong-type-arg
(symbol->string op)
"Wrong type argument in position 1 (expecting vtable): ~S"))
(define vtable-index-flags 1) ; FIXME: pull from struct.h
(define vtable-offset-flags (1+ vtable-index-flags))
(define vtable-validated-mask #b11)
(define vtable-validated-value #b11)
(with-cps cps
(letv flags mask res)
(letk knot-vtable
($kargs () () ($throw src 'throw/value+data not-vtable (vtable))))
(let$ body (is-vtable))
(letk k ($kargs () () ,body))
(letk ktest
($kargs ('res) (res)
($branch knot-vtable k src
'u64-imm-= vtable-validated-value (res))))
(letk kand
($kargs ('mask) (mask)
($continue ktest src
($primcall 'ulogand #f (flags mask)))))
(letk kflags
($kargs ('flags) (flags)
($continue kand src
($primcall 'load-u64 vtable-validated-mask ()))))
(build-term
($continue kflags src
($primcall 'word-ref/immediate
`(struct . ,vtable-offset-flags) (vtable-vtable))))))))
(define-primcall-converter allocate-struct
(lambda (cps k src op nwords vtable)
(ensure-vtable
cps src 'allocate-struct vtable
(lambda (cps)
(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 wrong-number
(vector 'wrong-number-of-args
(symbol->string op)
"Wrong number of initializers when instantiating ~A"))
(define has-unboxed
(vector 'wrong-type-arg
(symbol->string op)
"Expected vtable with no unboxed fields: ~A"))
(define (check-all-boxed cps kf kt vtable ptr word)
(if (< (* word 32) nwords)
(with-cps cps
(letv idx bits)
(let$ checkboxed (check-all-boxed kf kt vtable ptr (1+ word)))
(letk kcheckboxed ($kargs () () ,checkboxed))
(letk kcheck
($kargs ('bits) (bits)
($branch kf kcheckboxed src 'u64-imm-= 0 (bits))))
(letk kword
($kargs ('idx) (idx)
($continue kcheck src
($primcall 'u32-ref 'bitmask (vtable ptr idx)))))
(build-term
($continue kword src
($primcall 'load-u64 word ()))))
(with-cps cps
(build-term ($continue kt src ($values ()))))))
(with-cps cps
(letv rfields nfields ptr s)
(letk kwna
($kargs () () ($throw src 'throw/value wrong-number (vtable))))
(letk kunboxed
($kargs () () ($throw src 'throw/value+data has-unboxed (vtable))))
(letk kdone
($kargs () () ($continue k src ($values (s)))))
(letk ktag
($kargs ('s) (s)
($continue kdone src
($primcall 'scm-set!/tag 'struct (s vtable)))))
(letk kalloc
($kargs () ()
($continue ktag src
($primcall 'allocate-words/immediate
`(struct . ,(1+ nwords)) ()))))
(let$ checkboxed (check-all-boxed kunboxed kalloc vtable ptr 0))
(letk kcheckboxed ($kargs ('ptr) (ptr) ,checkboxed))
(letk kaccess
($kargs () ()
($continue kcheckboxed src
($primcall 'pointer-ref/immediate
`(struct . ,vtable-offset-unboxed-fields)
(vtable)))))
(letk knfields
($kargs ('nfields) (nfields)
($branch kwna kaccess src 'u64-imm-= nwords (nfields))))
(letk kassume
($kargs ('rfields) (rfields)
($continue knfields src
($primcall 'assume-u64 `(0 . ,(target-max-size-t/scm))
(rfields)))))
(build-term
($continue kassume src
($primcall 'word-ref/immediate
`(struct . ,vtable-offset-size) (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
@ -746,6 +854,14 @@
($continue k* src
($primcall 'scm-set!/immediate `(struct . ,pos) (struct val)))))))))
(define-primcall-converter struct-init!
(lambda (cps k src op param s val)
(define pos (1+ param))
(with-cps cps
(build-term
($continue k src
($primcall 'scm-set!/immediate `(struct . ,pos) (s val)))))))
(define-primcall-converter struct-ref
(lambda (cps k src op param struct idx)
(with-cps cps
@ -1047,8 +1163,6 @@
(string-length scm >u64)
(string-ref scm u64 >scm) (string-set! scm u64 scm)
(allocate-struct scm u64 >scm)
(rsh scm u64 >scm)
(lsh scm u64 >scm))
@ -1660,12 +1774,14 @@
(vector-set!/immediate n (v x)))
(('vector-init! v ($ <const> _ n) x)
(vector-init! n (v x)))
(('allocate-struct v ($ <const> _ (? uint? n)))
(allocate-struct/immediate n (v)))
(('allocate-struct v ($ <const> _ n))
(allocate-struct n (v)))
(('struct-ref s ($ <const> _ (? uint? n)))
(struct-ref/immediate n (s)))
(('struct-set! s ($ <const> _ (? uint? n)) x)
(struct-set!/immediate n (s x)))
(('struct-init! s ($ <const> _ n) x)
(struct-init! n (s x)))
(('add x ($ <const> _ (? number? y)))
(add/immediate y (x)))
(('add ($ <const> _ (? number? y)) x)
@ -2137,6 +2253,25 @@ integer."
args)
(list v))))))))
(($ <primcall> src 'make-struct/simple (vtable . args))
;; Expand to "allocate-struct" + "struct-init!".
(evaluate-args-eagerly-if-needed
src args
(lambda (args)
(define-syntax-rule (primcall name . args)
(make-primcall src 'name (list . args)))
(define-syntax-rule (const val)
(make-const src val))
(let ((s (primcall allocate-struct vtable (const (length args)))))
(with-lexicals src (s)
(list->seq
src
(append (map (lambda (idx arg)
(primcall struct-init! s (const idx) arg))
(iota (length args))
args)
(list s))))))))
(($ <primcall> src 'list args)
;; Expand to "cons".
(evaluate-args-eagerly-if-needed

1
module/language/tree-il/cps-primitives.scm
View file

@ -109,6 +109,7 @@
;; 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 struct-init! 3 0)
(define-cps-primitive class-of 1 1)

4
module/language/tree-il/primitives.scm
View file

@ -97,7 +97,7 @@
string-length string-ref string-set!
allocate-struct struct-vtable make-struct/no-tail struct-ref struct-set!
make-struct/simple struct-vtable struct-ref struct-set!
bytevector-length
@ -142,7 +142,7 @@
(define *primitive-constructors*
;; Primitives that return a fresh object.
'(acons cons cons* list vector make-vector
allocate-struct make-struct/no-tail
make-struct/simple
make-prompt-tag))
(define *primitive-accessors*