[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 08/16: Remaining /immediate instructions take primcall i
From: |
Andy Wingo |
Subject: |
[Guile-commits] 08/16: Remaining /immediate instructions take primcall imm param |
Date: |
Sun, 5 Nov 2017 09:00:41 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit cc1b23ffe8ba8169921102422a17e5ddf1ce4387
Author: Andy Wingo <address@hidden>
Date: Wed Nov 1 20:06:33 2017 +0100
Remaining /immediate instructions take primcall imm param
* module/language/cps/compile-bytecode.scm (compile-function): Update
add/immediate, etc.
* module/language/cps/slot-allocation.scm (compute-needs-slot):
Simplify.
* module/language/cps/specialize-primcalls.scm (specialize-primcalls):
Rework for add/immediate, etc.
* module/language/cps/types.scm (define-unary-result!)
(define-binary-result!): Take types as params instead of variables, so
we can share this code with /imm variants.
(add/immediate, sub/immediate, uadd/immediate, usub/immediate)
(umul/immediate, ulsh/immediate, ursh/immediate): Update type
inferrers.
---
module/language/cps/compile-bytecode.scm | 33 ++++------
module/language/cps/slot-allocation.scm | 20 +-----
module/language/cps/specialize-primcalls.scm | 70 ++++++++++----------
module/language/cps/types.scm | 99 ++++++++++++++++++----------
4 files changed, 112 insertions(+), 110 deletions(-)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 43c5ccb..43c6d71 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -182,25 +182,20 @@
(emit-char->integer asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'integer->char #f (src))
(emit-integer->char asm (from-sp dst) (from-sp (slot src))))
- (($ $primcall 'add/immediate #f (x y))
- (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant
y)))
- (($ $primcall 'sub/immediate #f (x y))
- (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) (constant
y)))
- (($ $primcall 'uadd/immediate #f (x y))
- (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x))
- (constant y)))
- (($ $primcall 'usub/immediate #f (x y))
- (emit-usub/immediate asm (from-sp dst) (from-sp (slot x))
- (constant y)))
- (($ $primcall 'umul/immediate #f (x y))
- (emit-umul/immediate asm (from-sp dst) (from-sp (slot x))
- (constant y)))
- (($ $primcall 'ursh/immediate #f (x y))
- (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x))
- (constant y)))
- (($ $primcall 'ulsh/immediate #f (x y))
- (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x))
- (constant y)))
+ (($ $primcall 'add/immediate y (x))
+ (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'sub/immediate y (x))
+ (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'uadd/immediate y (x))
+ (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'usub/immediate y (x))
+ (emit-usub/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'umul/immediate y (x))
+ (emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'ursh/immediate y (x))
+ (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'ulsh/immediate y (x))
+ (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
(($ $primcall 'builtin-ref idx ())
(emit-builtin-ref asm (from-sp dst) idx))
(($ $primcall 'scm->f64 #f (src))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 279e843..8259f48 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -324,24 +324,8 @@ the definitions that are live before and after LABEL, as
intsets."
(intset-union
needs-slot
(match cont
- (($ $kargs _ _ ($ $continue k src exp))
- (let ((defs (get-defs label)))
- (define (defs+* uses)
- (intset-union defs uses))
- (define (defs+ use)
- (intset-add defs use))
- (match exp
- (($ $const)
- empty-intset)
- ;; FIXME: Move all of these instructions to use $primcall
- ;; params.
- (($ $primcall (or 'add/immediate 'sub/immediate
- 'uadd/immediate 'usub/immediate 'umul/immediate
- 'ursh/immediate 'ulsh/immediate) #f
- (x y))
- (defs+ x))
- (_
- (defs+* (get-uses label))))))
+ (($ $kargs)
+ (intset-union (get-defs label) (get-uses label)))
(($ $kreceive arity k)
;; Only allocate results of function calls to slots if they are
;; used.
diff --git a/module/language/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
index 9d4545f..1bde78a 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017 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
@@ -52,42 +52,34 @@
(define (specialize-primcall name param args)
(define (rename name)
(build-exp ($primcall name param args)))
- (match (cons name args)
- (('make-vector (? u8? n) init)
- (build-exp
- ($primcall 'make-vector/immediate (intmap-ref constants n) (init))))
- (('vector-ref v (? u8? n))
- (build-exp
- ($primcall 'vector-ref/immediate (intmap-ref constants n) (v))))
- (('vector-set! v (? u8? n) x)
- (build-exp
- ($primcall 'vector-set!/immediate (intmap-ref constants n) (v x))))
- (('allocate-struct v (? u8? n))
- (build-exp
- ($primcall 'allocate-struct/immediate (intmap-ref constants n)
(v))))
- (('struct-ref s (? u8? n))
- (build-exp
- ($primcall 'struct-ref/immediate (intmap-ref constants n) (s))))
- (('struct-set! s (? u8? n) x)
- (build-exp
- ($primcall 'struct-set!/immediate (intmap-ref constants n) (s x))))
- (('add x (? u8? y)) (build-exp ($primcall 'add/immediate #f (x y))))
- (('add (? u8? x) y) (build-exp ($primcall 'add/immediate #f (y x))))
- (('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate #f (x y))))
- (('uadd x (? u8? y)) (build-exp ($primcall 'uadd/immediate #f (x y))))
- (('uadd (? u8? x) y) (build-exp ($primcall 'uadd/immediate #f (y x))))
- (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate #f (x y))))
- (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate #f (x y))))
- (('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? 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)))
+ (define-syntax-rule (specialize-case (pat (op c (arg ...))) ...)
+ (match (cons name args)
+ (pat
+ (let ((c (intmap-ref constants c)))
+ (build-exp ($primcall 'op c (arg ...)))))
+ ...
+ (_ #f)))
+ (specialize-case
+ (('make-vector (? u8? n) init) (make-vector/immediate n (init)))
+ (('vector-ref v (? u8? n)) (vector-ref/immediate n (v)))
+ (('vector-set! v (? u8? n) x) (vector-set!/immediate n (v x)))
+ (('allocate-struct v (? u8? n)) (allocate-struct/immediate n (v)))
+ (('struct-ref s (? u8? n)) (struct-ref/immediate n (s)))
+ (('struct-set! s (? u8? n) x) (struct-set!/immediate n (s x)))
+ (('add x (? u8? y)) (add/immediate y (x)))
+ (('add (? u8? y) x) (add/immediate y (x)))
+ (('sub x (? u8? y)) (sub/immediate y (x)))
+ (('uadd x (? u8? y)) (uadd/immediate y (x)))
+ (('uadd (? u8? y) x) (uadd/immediate y (x)))
+ (('usub x (? u8? y)) (usub/immediate y (x)))
+ (('umul x (? u8? y)) (umul/immediate y (x)))
+ (('umul (? u8? y) x) (umul/immediate y (x)))
+ (('ursh x (? u6? y)) (ursh/immediate y (x)))
+ (('ulsh x (? u6? y)) (ulsh/immediate y (x)))
+ (('scm->f64 (? f64? var)) (load-f64 var ()))
+ (('scm->u64 (? u64? var)) (load-u64 var ()))
+ (('scm->u64/truncate (? u64? var)) (load-u64 var ()))
+ (('scm->s64 (? s64? var)) (load-s64 var ()))))
(intmap-map
(lambda (label cont)
(match cont
@@ -99,3 +91,7 @@
cont)))
(_ cont)))
conts)))
+
+;;; Local Variables:
+;;; eval: (put 'specialize-case 'scheme-indent-function 0)
+;;; End:
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 606d6d0..73a66a6 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1091,27 +1091,24 @@ minimum, and maximum."
(define-s64-comparison-inferrer (s64-> > <=))
;; Arithmetic.
-(define-syntax-rule (define-unary-result! a result min max)
- (let ((min* min)
- (max* max)
- (type (logand (&type a) &number)))
+(define-syntax-rule (define-unary-result! a-type$ result min$ max$)
+ (let ((min min$) (max max$) (type a-type$))
(cond
- ((not (= type (&type a)))
- ;; Not a number. Punt and do nothing.
+ ((not (type<=? type &number))
+ ;; Not definitely a number. Punt and do nothing.
(define! result &all-types -inf.0 +inf.0))
;; Complex numbers don't have a range.
((eqv? type &complex)
(define! result &complex -inf.0 +inf.0))
(else
- (define! result type min* max*)))))
+ (define! result type min max)))))
-(define-syntax-rule (define-binary-result! a b result closed? min max)
- (let ((min* min)
- (max* max)
- (a-type (logand (&type a) &number))
- (b-type (logand (&type b) &number)))
+(define-syntax-rule (define-binary-result! a-type$ b-type$ result closed?
+ min$ max$)
+ (let* ((min min$) (max max$) (a-type a-type$) (b-type b-type$)
+ (type (logior a-type b-type)))
(cond
- ((or (not (= a-type (&type a))) (not (= b-type (&type b))))
+ ((not (type<=? type &number))
;; One input not a number. Perhaps we end up dispatching to
;; GOOPS.
(define! result &all-types -inf.0 +inf.0))
@@ -1121,33 +1118,35 @@ minimum, and maximum."
((or (eqv? a-type &flonum) (eqv? b-type &flonum))
;; If one argument is a flonum, the result will be flonum or
;; possibly complex.
- (let ((result-type (logand (logior a-type b-type)
- (logior &complex &flonum))))
- (define! result result-type min* max*)))
+ (let ((result-type (logand type (logior &complex &flonum))))
+ (define! result result-type min max)))
;; Exact integers are closed under some operations.
- ((and closed? (type<=? (logior a-type b-type) &exact-integer))
- (define-exact-integer! result min* max*))
+ ((and closed? (type<=? type &exact-integer))
+ (define-exact-integer! result min max))
(else
- (let* ((type (logior a-type b-type))
- ;; Fractions may become integers.
+ (let* (;; Fractions may become integers.
(type (if (zero? (logand type &fraction))
type
(logior type &exact-integer)))
;; Integers may become fractions under division.
- (type (if (or closed?
- (zero? (logand type (logior &exact-integer))))
+ (type (if (or closed? (zero? (logand type &exact-integer)))
type
(logior type &fraction))))
- (define! result type min* max*))))))
+ (define! result type min max))))))
(define-simple-type-checker (add &number &number))
-(define-type-aliases add add/immediate)
+(define-simple-type-checker (add/immediate &number))
(define-type-checker (fadd a b) #t)
(define-type-checker (uadd a b) #t)
(define-type-inferrer (add a b result)
- (define-binary-result! a b result #t
+ (define-binary-result! (&type a) (&type b) result #t
(+ (&min a) (&min b))
(+ (&max a) (&max b))))
+(define-type-inferrer/param (add/immediate param a result)
+ (let ((b-type (type-entry-type (constant-type param))))
+ (define-binary-result! (&type a) b-type result #t
+ (+ (&min a) param)
+ (+ (&max a) param))))
(define-type-inferrer (fadd a b result)
(define! result &f64
(+ (&min a) (&min b))
@@ -1158,16 +1157,26 @@ minimum, and maximum."
(if (<= max &u64-max)
(define! result &u64 (+ (&min/0 a) (&min/0 b)) max)
(define! result &u64 0 &u64-max))))
-(define-type-aliases uadd uadd/immediate)
+(define-type-inferrer/param (uadd/immediate param a result)
+ ;; Handle wraparound.
+ (let ((max (+ (&max/u64 a) param)))
+ (if (<= max &u64-max)
+ (define! result &u64 (+ (&min/0 a) param) max)
+ (define! result &u64 0 &u64-max))))
(define-simple-type-checker (sub &number &number))
-(define-type-aliases sub sub/immediate)
+(define-simple-type-checker (sub/immediate &number))
(define-type-checker (fsub a b) #t)
(define-type-checker (usub a b) #t)
(define-type-inferrer (sub a b result)
- (define-binary-result! a b result #t
+ (define-binary-result! (&type a) (&type b) result #t
(- (&min a) (&max b))
(- (&max a) (&min b))))
+(define-type-inferrer/param (sub/immediate param a result)
+ (let ((b-type (type-entry-type (constant-type param))))
+ (define-binary-result! (&type a) b-type result #t
+ (- (&min a) param)
+ (- (&max a) param))))
(define-type-inferrer (fsub a b result)
(define! result &f64
(- (&min a) (&max b))
@@ -1178,7 +1187,12 @@ minimum, and maximum."
(if (< min 0)
(define! result &u64 0 &u64-max)
(define! result &u64 min (- (&max/u64 a) (&min/0 b))))))
-(define-type-aliases usub usub/immediate)
+(define-type-inferrer/param (usub/immediate param a result)
+ ;; Handle wraparound.
+ (let ((min (- (&min/0 a) param)))
+ (if (< min 0)
+ (define! result &u64 0 &u64-max)
+ (define! result &u64 min (- (&max/u64 a) param)))))
(define-simple-type-checker (mul &number &number))
(define-type-checker (fmul a b) #t)
@@ -1215,7 +1229,7 @@ minimum, and maximum."
(mul-result-range (eqv? a b) nan-impossible?
min-a max-a min-b max-b))
(lambda (min max)
- (define-binary-result! a b result #t min max)))))
+ (define-binary-result! (&type a) (&type b) result #t min max)))))
(define-type-inferrer (fmul a b result)
(let ((min-a (&min a)) (max-a (&max a))
(min-b (&min b)) (max-b (&max b))
@@ -1231,7 +1245,12 @@ minimum, and maximum."
(if (<= max &u64-max)
(define! result &u64 (* (&min/0 a) (&min/0 b)) max)
(define! result &u64 0 &u64-max))))
-(define-type-aliases umul umul/immediate)
+(define-type-inferrer/param (umul/immediate param a result)
+ ;; Handle wraparound.
+ (let ((max (* (&max/u64 a) param)))
+ (if (<= max &u64-max)
+ (define! result &u64 (* (&min/0 a) param) max)
+ (define! result &u64 0 &u64-max))))
(define-type-checker (div a b)
(and (check-type a &number -inf.0 +inf.0)
@@ -1265,7 +1284,7 @@ minimum, and maximum."
(call-with-values (lambda ()
(div-result-range min-a max-a min-b max-b))
(lambda (min max)
- (define-binary-result! a b result #f min max)))))
+ (define-binary-result! (&type a) (&type b) result #f min max)))))
(define-type-inferrer (fdiv a b result)
(let ((min-a (&min a)) (max-a (&max a))
(min-b (&min b)) (max-b (&max b)))
@@ -1382,12 +1401,13 @@ minimum, and maximum."
(define-simple-type-checker (ursh &u64 &u64))
(define-type-inferrer (ursh a b result)
- (restrict! a &u64 0 &u64-max)
- (restrict! b &u64 0 &u64-max)
(define! result &u64
(ash (&min/0 a) (- (&max/u64 b)))
(ash (&max/u64 a) (- (&min/0 b)))))
-(define-type-aliases ursh ursh/immediate)
+(define-type-inferrer/param (ursh/immediate param a result)
+ (define! result &u64
+ (ash (&min/0 a) (- param))
+ (ash (&max/u64 a) (- param))))
(define-simple-type-checker (ulsh &u64 &u64))
(define-type-inferrer (ulsh a b result)
@@ -1401,7 +1421,14 @@ minimum, and maximum."
(ash (&max/u64 a) (&max/u64 b)))
;; Otherwise assume the whole range.
(define! result &u64 0 &u64-max)))
-(define-type-aliases ulsh ulsh/immediate)
+(define-type-inferrer/param (ulsh/immediate param a result)
+ (if (and (< param 64) (<= (ash (&max/u64 a) param) &u64-max))
+ ;; No overflow; we can be precise.
+ (define! result &u64
+ (ash (&min/0 a) param)
+ (ash (&max/u64 a) param))
+ ;; Otherwise assume the whole range.
+ (define! result &u64 0 &u64-max)))
(define (next-power-of-two n)
(let lp ((out 1))
- [Guile-commits] 05/16: Immediate variants of vector-ref, etc use immediate param, (continued)
- [Guile-commits] 05/16: Immediate variants of vector-ref, etc use immediate param, Andy Wingo, 2017/11/05
- [Guile-commits] 15/16: error, scm-error primcalls expand to `throw', Andy Wingo, 2017/11/05
- [Guile-commits] 07/16: builtin-ref takes immediate parameter, Andy Wingo, 2017/11/05
- [Guile-commits] 09/16: reify-primitives reifies constants for out-of-range imm params, Andy Wingo, 2017/11/05
- [Guile-commits] 03/16: load-f64, etc take immediate parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 04/16: free-ref, free-set take immediate parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 11/16: (system base types) uses target's idea of max size_t, Andy Wingo, 2017/11/05
- [Guile-commits] 16/16: Add new "throw" VM ops, Andy Wingo, 2017/11/05
- [Guile-commits] 14/16: Add lsh, rsh instructions, Andy Wingo, 2017/11/05
- [Guile-commits] 06/16: Immediate parameter for struct-ref et al, Andy Wingo, 2017/11/05
- [Guile-commits] 08/16: Remaining /immediate instructions take primcall imm param,
Andy Wingo <=
- [Guile-commits] 01/16: $primcall has a "param" member, Andy Wingo, 2017/11/05