[Guile-commits] 08/16: Remaining /immediate instructions take primcall imm param

[Andy Wingo]

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))