diff options
-rw-r--r-- | module/language/cps/closure-conversion.scm | 19 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 18 | ||||
-rw-r--r-- | module/language/cps/cse.scm | 4 | ||||
-rw-r--r-- | module/language/cps/dce.scm | 3 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 11 | ||||
-rw-r--r-- | module/language/cps/reify-primitives.scm | 3 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 2 | ||||
-rw-r--r-- | module/language/cps/specialize-primcalls.scm | 3 | ||||
-rw-r--r-- | module/language/cps/types.scm | 50 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 9 |
10 files changed, 18 insertions, 104 deletions
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 2e5a910ed..550e1f9ab 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -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 diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 79459cf0e..ec93eaa5c 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -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)))) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 2b1a229ca..f3c333c1a 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -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)) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 0de6101d7..0a3a311df 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -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) _ diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 473b280ba..87c2540a2 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -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) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 2dc813694..4580f837e 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -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)) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 48d98771e..3f73a209e 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -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 diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index b791a2012..5d578053a 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -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))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 0c9ce845c..230c1ebc0 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -834,56 +834,6 @@ minimum, and maximum." ;;; -;;; 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))) - - - - -;;; ;;; Structs. ;;; diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 7af7050db..489bfd56f 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -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 |