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

CPS pass now expects exploded vector primitives

Browse source 
* module/language/cps/closure-conversion.scm (convert-one): Reify
  make-vector inline, without field initialization.
* module/language/cps/cse.scm (compute-equivalent-subexpressions):
* module/language/cps/dce.scm (compute-live-code):
* module/language/cps/effects-analysis.scm:
* module/language/cps/reify-primitives.scm (reify-primitives):
* module/language/cps/slot-allocation.scm (compute-var-representations):
* module/language/cps/specialize-primcalls.scm (specialize-primcalls):
* module/language/cps/types.scm:
* module/language/cps/compile-bytecode.scm (compile-function): Remove
  cases for make-vector, vector-ref, etc.
* module/system/vm/assembler.scm: Remove make-vector, vector-ref etc
  exports.
This commit is contained in:
Andy Wingo 2018-01-07 16:14:09 +01:00
parent 06cf66d6cc
commit 6e100c9ba6
10 changed files with 18 additions and 104 deletions
Download patch file Download diff file Expand all files Collapse all files

19
module/language/cps/closure-conversion.scm
View file

@ -35,6 +35,7 @@
filter-map
))
#:use-module (srfi srfi-11)
#:use-module (system base types internal)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
@ -536,10 +537,20 @@ term."
(unless (> nfree 2)
(error "unexpected well-known nullary, unary, or binary closure"))
(with-cps cps
($ (with-cps-constants ((false #f))
(build-term
($continue k src
($primcall 'make-vector/immediate nfree (false))))))))))
(letv v w0)
(letk k* ($kargs () () ($continue k src ($values (v)))))
(letk ktag1
($kargs ('w0) (w0)
($continue k* src
($primcall 'word-set!/immediate '(vector . 0) (v w0)))))
(letk ktag0
($kargs ('v) (v)
($continue ktag1 src
($primcall 'load-u64 (+ %tc7-vector (ash nfree 8)) ()))))
(build-term
($continue ktag0 src
($primcall 'allocate-words/immediate `(vector . ,(1+ nfree))
())))))))
(define (init-closure cps k src var known? free)
"Initialize the free variables @var{closure-free} in a closure

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

@ -175,18 +175,6 @@
idx))
(($ $primcall 'free-ref idx (closure))
(emit-free-ref asm (from-sp dst) (from-sp (slot closure)) idx))
(($ $primcall 'vector-ref #f (vector index))
(emit-vector-ref asm (from-sp dst) (from-sp (slot vector))
(from-sp (slot index))))
(($ $primcall 'make-vector #f (length init))
(emit-make-vector asm (from-sp dst) (from-sp (slot length))
(from-sp (slot init))))
(($ $primcall 'make-vector/immediate length (init))
(emit-make-vector/immediate asm
(from-sp dst) length (from-sp (slot init))))
(($ $primcall 'vector-ref/immediate index (vector))
(emit-vector-ref/immediate asm
(from-sp dst) (from-sp (slot vector)) index))
(($ $primcall 'allocate-struct #f (vtable nfields))
(emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable))
(from-sp (slot nfields))))
@ -336,12 +324,6 @@
(($ $primcall 'struct-set!/immediate idx (struct value))
(emit-struct-set!/immediate asm (from-sp (slot struct)) idx
(from-sp (slot value))))
(($ $primcall 'vector-set! #f (vector index value))
(emit-vector-set! asm (from-sp (slot vector)) (from-sp (slot index))
(from-sp (slot value))))
(($ $primcall 'vector-set!/immediate index (vector value))
(emit-vector-set!/immediate asm (from-sp (slot vector))
index (from-sp (slot value))))
(($ $primcall 'string-set! #f (string index char))
(emit-string-set! asm (from-sp (slot string)) (from-sp (slot index))
(from-sp (slot char))))

4
module/language/cps/cse.scm
View file

@ -263,10 +263,6 @@ false. It could be that both true and false proofs are available."
((set-car! #f o x) (x <- car #f o))
((set-cdr! #f o y) (y <- cdr #f o))
;; FIXME: how to propagate make-vector/immediate -> vector-length?
((v <- make-vector #f n x) (n <- vector-length #f v))
((vector-set! #f v i x) (x <- vector-ref #f v i))
((vector-set!/immediate i v x) (x <- vector-ref/immediate i v))
((s <- allocate-struct #f v n) (v <- struct-vtable #f s))
((s <- allocate-struct/immediate n v) (v <- struct-vtable #f s))
((struct-set! #f s i x) (x <- struct-ref #f s i))

3
module/language/cps/dce.scm
View file

@ -188,8 +188,7 @@ sites."
(and (causes-effect? fx &write)
(match exp
(($ $primcall
(or 'vector-set! 'vector-set!/immediate
'set-car! 'set-cdr!
(or 'set-car! 'set-cdr!
'box-set!
'scm-set! 'scm-set!/tag 'scm-set!/immediate
'word-set! 'word-set!/immediate) _

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

@ -402,17 +402,6 @@ the LABELS that are clobbered by the effects of LABEL."
((box-ref v) (&read-object &box) &type-check)
((box-set! v x) (&write-object &box) &type-check))
;; Vectors.
(define-primitive-effects* param
((vector . _) (&allocate &vector))
((make-vector n init) (&allocate &vector))
((make-vector/immediate init) (&allocate &vector))
((vector-ref v n) (&read-object &vector) &type-check)
((vector-ref/immediate v) (&read-field &vector param) &type-check)
((vector-set! v n x) (&write-object &vector) &type-check)
((vector-set!/immediate v x) (&write-field &vector param) &type-check)
((vector-length v) &type-check))
;; Structs.
(define-primitive-effects* param
((allocate-struct vt n) (&allocate &struct) &type-check)

3
module/language/cps/reify-primitives.scm
View file

@ -310,9 +310,6 @@
((sub/immediate (u8? y) x) (sub x y))
(_
(reify-u64-constants
((make-vector/immediate (u8? size) init) (make-vector size init))
((vector-ref/immediate (u8? idx) v) (vector-ref v idx))
((vector-set!/immediate (u8? idx) v val) (vector-set! v idx val))
((allocate-struct/immediate (u8? size) vt) (allocate-struct vt size))
((struct-ref/immediate (u8? idx) s) (struct-ref s idx))
((struct-set!/immediate (u8? idx) s val) (struct-set! s idx val))

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

@ -752,7 +752,7 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-add representations var 'f64))
(($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
'char->integer 's64->u64
'bv-length 'vector-length 'string-length
'bv-length 'string-length
'uadd 'usub 'umul
'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
'uadd/immediate 'usub/immediate 'umul/immediate

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

@ -121,9 +121,6 @@
...
(_ #f)))
(specialize-case
(('make-vector (? uint? n) init) (make-vector/immediate n (init)))
(('vector-ref v (? uint? n)) (vector-ref/immediate n (v)))
(('vector-set! v (? uint? n) x) (vector-set!/immediate n (v x)))
(('allocate-struct v (? uint? n)) (allocate-struct/immediate n (v)))
(('struct-ref s (? uint? n)) (struct-ref/immediate n (s)))
(('struct-set! s (? uint? n) x) (struct-set!/immediate n (s x)))

50
module/language/cps/types.scm
View file

@ -831,56 +831,6 @@ minimum, and maximum."
(restrict! box &box 1 1))
;;;
;;; Vectors.
;;;
(define-syntax-rule (&max/vector x)
(min (&max x) (target-max-vector-length)))
(define-simple-type-checker (make-vector (&u64 0 (target-max-vector-length))
&all-types))
(define-type-inferrer (make-vector size init result)
(restrict! size &u64 0 (target-max-vector-length))
(define! result &vector (&min/0 size) (&max/vector size)))
(define-type-checker (vector-ref v idx)
(and (check-type v &vector 0 (target-max-vector-length))
(check-type idx &u64 0 (1- (&min v)))))
(define-type-inferrer (vector-ref v idx result)
(restrict! v &vector (1+ (&min/0 idx)) (target-max-vector-length))
(restrict! idx &u64 0 (1- (&max/vector v)))
(define! result &all-types -inf.0 +inf.0))
(define-type-checker (vector-set! v idx val)
(and (check-type v &vector 0 (target-max-vector-length))
(check-type idx &u64 0 (1- (&min v)))))
(define-type-inferrer (vector-set! v idx val)
(restrict! v &vector (1+ (&min/0 idx)) (target-max-vector-length))
(restrict! idx &u64 0 (1- (&max/vector v))))
(define-type-inferrer/param (make-vector/immediate size init result)
(define! result &vector size size))
(define-type-checker/param (vector-ref/immediate idx v)
(and (check-type v &vector 0 (target-max-vector-length)) (< idx (&min v))))
(define-type-inferrer/param (vector-ref/immediate idx v result)
(restrict! v &vector (1+ idx) (target-max-vector-length))
(define! result &all-types -inf.0 +inf.0))
(define-type-checker/param (vector-set!/immediate idx v val)
(and (check-type v &vector 0 (target-max-vector-length)) (< idx (&min v))))
(define-type-inferrer/param (vector-set!/immediate idx v val)
(restrict! v &vector (1+ idx) (target-max-vector-length)))
(define-simple-type-checker (vector-length &vector))
(define-type-inferrer (vector-length v result)
(restrict! v &vector 0 (target-max-vector-length))
(define! result &u64 (&min/0 v) (&max/vector v)))
;;;

9
module/system/vm/assembler.scm
View file

@ -1,6 +1,6 @@
;;; Guile bytecode assembler
;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@ -243,13 +243,6 @@
emit-ulsh/immediate
emit-char->integer
emit-integer->char
emit-make-vector
emit-make-vector/immediate
emit-vector-length
emit-vector-ref
emit-vector-ref/immediate
emit-vector-set!
emit-vector-set!/immediate
emit-struct-vtable
emit-allocate-struct/immediate
emit-struct-ref/immediate