mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
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.
This commit is contained in:
Andy Wingo
parent
56d639bfe5
commit
cc1b23ffe8
4 changed files with 112 additions and 110 deletions
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue