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

load-f64, etc take immediate parameters

Browse source 
* module/language/cps/compile-bytecode.scm (compile-function): Make
  load-f64, load-s64, and load-u64 take an immediate parameter instead
  of a CPS value.
* module/language/cps/effects-analysis.scm: Remove CPS argument from
  immediate load instructions.
* module/language/cps/slot-allocation.scm (compute-needs-slot): Remove
  special case for load-64 etc.
* module/language/cps/specialize-numbers.scm
  (specialize-u64-scm-comparison): Adapt.
* module/language/cps/specialize-primcalls.scm (specialize-primcalls):
  Adapt.
* module/language/cps/types.scm (define-type-inferrer*): Also take param
  argument.
  (define-type-inferrer, define-predicate-inferrer): Adapt.
  (define-type-inferrer/param): New helper.
  (load-f64, load-s64, load-u64): Adapt inferrers to pass on value from
  param.
* module/language/cps/utils.scm (compute-constant-values): Adapt.
This commit is contained in:
Andy Wingo 2017-11-01 14:10:17 +01:00
parent 4fb538e90e
commit 6be04684e6
7 changed files with 31 additions and 27 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -206,22 +206,22 @@
(emit-builtin-ref asm (from-sp dst) (constant name)))
(($ $primcall 'scm->f64 #f (src))
(emit-scm->f64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-f64 #f (src))
(emit-load-f64 asm (from-sp dst) (constant src)))
(($ $primcall 'load-f64 val ())
(emit-load-f64 asm (from-sp dst) val))
(($ $primcall 'f64->scm #f (src))
(emit-f64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->u64 #f (src))
(emit-scm->u64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->u64/truncate #f (src))
(emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-u64 #f (src))
(emit-load-u64 asm (from-sp dst) (constant src)))
(($ $primcall 'load-u64 val ())
(emit-load-u64 asm (from-sp dst) val))
(($ $primcall (or 'u64->scm 'u64->scm/unlikely) #f (src))
(emit-u64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->s64 #f (src))
(emit-scm->s64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-s64 #f (src))
(emit-load-s64 asm (from-sp dst) (constant src)))
(($ $primcall 'load-s64 val ())
(emit-load-s64 asm (from-sp dst) val))
(($ $primcall (or 's64->scm 's64->scm/unlikely) #f (src))
(emit-s64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'bv-length #f (bv))

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

@ -375,15 +375,15 @@ is or might be a read or a write to the same location as A."
;; Unboxed floats and integers.
(define-primitive-effects
((scm->f64 _) &type-check)
((load-f64 _))
((load-f64))
((f64->scm _))
((scm->u64 _) &type-check)
((scm->u64/truncate _) &type-check)
((load-u64 _))
((load-u64))
((u64->scm _))
((u64->scm/unlikely _))
((scm->s64 _) &type-check)
((load-s64 _))
((load-s64))
((s64->scm _))
((s64->scm/unlikely _))
((untag-fixnum _)))

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

@ -335,8 +335,6 @@ the definitions that are live before and after LABEL, as intsets."
empty-intset)
;; FIXME: Move all of these instructions to use $primcall
;; params.
(($ $primcall (or 'load-f64 'load-u64 'load-s64) #f (val))
empty-intset)
(($ $primcall 'free-ref #f (closure slot))
(defs+ closure))
(($ $primcall 'free-set! #f (closure slot value))

6
module/language/cps/specialize-numbers.scm
View file

@ -137,7 +137,7 @@
(define (specialize-u64-scm-comparison cps kf kt src op a-u64 b-scm)
(let ((u64-op (symbol-append 'u64- op)))
(with-cps cps
(letv u64 s64 zero z64 sunk)
(letv u64 s64 z64 sunk)
(letk kheap ($kargs ('sunk) (sunk)
($continue kf src
($branch kt ($primcall op #f (sunk b-scm))))))
@ -154,10 +154,8 @@
(letk kz64 ($kargs ('z64) (z64)
($continue (case op ((< <= =) kf) (else kt)) src
($branch kcmp ($primcall 's64-<= #f (z64 s64))))))
(letk kzero ($kargs ('zero) (zero)
($continue kz64 src ($primcall 'load-s64 #f (zero)))))
(letk ks64 ($kargs ('s64) (s64)
($continue kzero src ($const 0))))
($continue kz64 src ($primcall 'load-s64 0 ()))))
(letk kfix ($kargs () ()
($continue ks64 src
($primcall 'untag-fixnum #f (b-scm)))))

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

@ -69,10 +69,12 @@
(('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate #f (y x))))
(('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate #f (x y))))
(('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate #f (x y))))
(('scm->f64 (? f64?)) (rename 'load-f64))
(('scm->u64 (? u64?)) (rename 'load-u64))
(('scm->u64/truncate (? u64?)) (rename 'load-u64))
(('scm->s64 (? s64?)) (rename 'load-s64))
(('scm->f64 (? f64? var))
(build-exp ($primcall 'load-f64 (intmap-ref constants var) ())))
(((or 'scm->u64 'scm->u64/truncate) (? u64? var))
(build-exp ($primcall 'load-u64 (intmap-ref constants var) ())))
(('scm->s64 (? s64? var))
(build-exp ($primcall 'load-s64 (intmap-ref constants var) ())))
(_ #f)))
(intmap-map
(lambda (label cont)

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

@ -426,7 +426,7 @@ minimum, and maximum."
(<= min (&min arg))
(<= (&max arg) max)))
(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...)
(define-syntax-rule (define-type-inferrer* (name param succ var ...) body ...)
(hashq-set!
*type-inferrers*
'name
@ -450,10 +450,13 @@ minimum, and maximum."
out)))))
(define-syntax-rule (define-type-inferrer (name arg ...) body ...)
(define-type-inferrer* (name succ arg ...) body ...))
(define-type-inferrer* (name param succ arg ...) body ...))
(define-syntax-rule (define-type-inferrer/param (name param arg ...) body ...)
(define-type-inferrer* (name param succ arg ...) body ...))
(define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...)
(define-type-inferrer* (name succ arg ...)
(define-type-inferrer* (name param succ arg ...)
(let ((true? (not (zero? succ))))
body ...)))
@ -837,7 +840,8 @@ minimum, and maximum."
(define-type-inferrer (scm->f64 scm result)
(restrict! scm &real -inf.0 +inf.0)
(define! result &f64 (&min scm) (&max scm)))
(define-type-aliases scm->f64 load-f64)
(define-type-inferrer/param (load-f64 param result)
(define! result &f64 param param))
(define-type-checker (f64->scm f64)
#t)
@ -849,7 +853,8 @@ minimum, and maximum."
(define-type-inferrer (scm->u64 scm result)
(restrict! scm &exact-integer 0 &u64-max)
(define! result &u64 (&min/0 scm) (&max/u64 scm)))
(define-type-aliases scm->u64 load-u64)
(define-type-inferrer/param (load-u64 param result)
(define! result &u64 param param))
(define-type-checker (scm->u64/truncate scm)
(check-type scm &exact-integer &range-min &range-max))
@ -868,8 +873,9 @@ minimum, and maximum."
(define-type-inferrer (scm->s64 scm result)
(restrict! scm &exact-integer &s64-min &s64-max)
(define! result &s64 (&min/s64 scm) (&max/s64 scm)))
(define-type-aliases scm->s64 load-s64)
(define-type-aliases s64->scm s64->scm/unlikely)
(define-type-inferrer/param (load-s64 param result)
(define! result &s64 param param))
(define-simple-type-checker (untag-fixnum &fixnum))
(define-type-inferrer (untag-fixnum scm result)

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

@ -205,8 +205,8 @@ disjoint, an error will be signalled."
(intmap-fold
(lambda (var exp out)
(match exp
(($ $primcall (or 'load-f64 'load-u64 'load-s64) #f (val))
(intmap-add! out var (intmap-ref out val)))
(($ $primcall (or 'load-f64 'load-u64 'load-s64) val ())
(intmap-add! out var val))
;; Punch through type conversions to allow uadd to specialize
;; to uadd/immediate.
(($ $primcall 'scm->f64 #f (val))