From 6be04684e677ed979d0675568cc2284ef8782327 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Nov 2017 14:10:17 +0100 Subject: [PATCH] load-f64, etc take immediate parameters * 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. --- module/language/cps/compile-bytecode.scm | 12 ++++++------ module/language/cps/effects-analysis.scm | 6 +++--- module/language/cps/slot-allocation.scm | 2 -- module/language/cps/specialize-numbers.scm | 6 ++---- module/language/cps/specialize-primcalls.scm | 10 ++++++---- module/language/cps/types.scm | 18 ++++++++++++------ module/language/cps/utils.scm | 4 ++-- 7 files changed, 31 insertions(+), 27 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index d206d2671..57a570f3c 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -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)) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 3f3d8b79f..266ef5a4e 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -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 _))) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 9c70a8bb7..624ddf7d3 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -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)) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 3551a9c4e..aa08c8ff9 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -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))))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 5b3c6dfdb..41629f774 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -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) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 72570e4af..414c37825 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -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) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index 40445cfb5..01768e6d7 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -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))