guile/module/language/cps/type-fold.scm

;;; Abstract constant folding on CPS
;;; Copyright (C) 2014, 2015, 2017, 2018 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 License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;; 
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;; 
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;;
;;; This pass uses the abstract interpretation provided by type analysis
;;; to fold constant values and type predicates.  It is most profitably
;;; run after CSE, to take advantage of scalar replacement.
;;;
;;; Code:

(define-module (language cps type-fold)
  #:use-module (ice-9 match)
  #:use-module (language cps)
  #:use-module (language cps utils)
  #:use-module (language cps renumber)
  #:use-module (language cps types)
  #:use-module (language cps with-cps)
  #:use-module (language cps intmap)
  #:use-module (language cps intset)
  #:use-module (system base target)
  #:export (type-fold))




;; Branch folders.

(define &scalar-types
  (logior &fixnum &bignum &flonum &char &special-immediate))

(define *branch-folders* (make-hash-table))

(define-syntax-rule (define-branch-folder op f)
  (hashq-set! *branch-folders* 'op f))

(define-syntax-rule (define-branch-folder-alias to from)
  (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))

(define-syntax-rule (define-unary-branch-folder* (op param arg min max)
                      body ...)
  (define-branch-folder op (lambda (param arg min max) body ...)))

(define-syntax-rule (define-unary-branch-folder (op arg min max) body ...)
  (define-unary-branch-folder* (op param arg min max) body ...))

(define-syntax-rule (define-binary-branch-folder (op arg0 min0 max0
                                                       arg1 min1 max1)
                      body ...)
  (define-branch-folder op (lambda (param arg0 min0 max0 arg1 min1 max1) body ...)))

(define-syntax-rule (define-special-immediate-predicate-folder op imin imax)
  (define-unary-branch-folder (op type min max)
    (let ((type* (logand type &special-immediate)))
      (cond
       ((zero? (logand type &special-immediate)) (values #t #f))
       ((eqv? type &special-immediate)
        (cond
         ((or (< imax min) (< max imin)) (values #t #f))
         ((<= imin min max imax) (values #t #t))
         (else (values #f #f))))
       (else (values #f #f))))))

(define-special-immediate-predicate-folder eq-nil? &nil &nil)
(define-special-immediate-predicate-folder eq-eol? &null &null)
(define-special-immediate-predicate-folder eq-false? &false &false)
(define-special-immediate-predicate-folder eq-true? &true &true)
(define-special-immediate-predicate-folder unspecified? &unspecified &unspecified)
(define-special-immediate-predicate-folder undefined? &undefined &undefined)
(define-special-immediate-predicate-folder eof-object? &eof &eof)
(define-special-immediate-predicate-folder null? &null &nil)
(define-special-immediate-predicate-folder false? &nil &false)
(define-special-immediate-predicate-folder nil? &null &false) ;; &nil in middle

(define-syntax-rule (define-unary-type-predicate-folder op &type)
  (define-unary-branch-folder (op type min max)
    (let ((type* (logand type &type)))
      (cond
       ((zero? type*) (values #t #f))
       ((eqv? type type*) (values #t #t))
       (else (values #f #f))))))

(define-unary-branch-folder (heap-object? type min max)
  (define &immediate-types (logior &fixnum &char &special-immediate))
  (cond
   ((zero? (logand type &immediate-types)) (values #t #t))
   ((type<=? type &immediate-types) (values #t #f))
   (else (values #f #f))))

(define-unary-branch-folder (heap-number? type min max)
  (define &types (logior &bignum &flonum &fraction &complex))
  (cond
   ((zero? (logand type &types)) (values #t #f))
   ((type<=? type &types) (values #t #t))
   (else (values #f #f))))

;; All the cases that are in compile-bytecode.
(define-unary-type-predicate-folder fixnum? &fixnum)
(define-unary-type-predicate-folder bignum? &bignum)
(define-unary-type-predicate-folder pair? &pair)
(define-unary-type-predicate-folder symbol? &symbol)
(define-unary-type-predicate-folder variable? &box)
(define-unary-type-predicate-folder mutable-vector? &mutable-vector)
(define-unary-type-predicate-folder immutable-vector? &immutable-vector)
(define-unary-type-predicate-folder struct? &struct)
(define-unary-type-predicate-folder string? &string)
(define-unary-type-predicate-folder number? &number)
(define-unary-type-predicate-folder char? &char)

(define-unary-branch-folder (vector? type min max)
  (cond
   ((zero? (logand type &vector)) (values #t #f))
   ((type<=? type &vector) (values #t #t))
   (else (values #f #f))))

(define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1)
  (cond
   ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0))
    (values #t #f))
   ((and (eqv? type0 type1)
         (eqv? min0 min1 max0 max1)
         (zero? (logand type0 (1- type0)))
         (not (zero? (logand type0 &scalar-types))))
    (values #t #t))
   (else
    (values #f #f))))
(define-branch-folder-alias heap-numbers-equal? eq?)

(define (compare-exact-ranges min0 max0 min1 max1)
  (and (cond ((< max0 min1) '<)
             ((> min0 max1) '>)
             ((= min0 max0 min1 max1) '=)
             ((<= max0 min1) '<=)
             ((>= min0 max1) '>=)
             (else #f))))

(define-binary-branch-folder (< type0 min0 max0 type1 min1 max1)
  (if (type<=? (logior type0 type1) &exact-number)
      (case (compare-exact-ranges min0 max0 min1 max1)
        ((<) (values #t #t))
        ((= >= >) (values #t #f))
        (else (values #f #f)))
      (values #f #f)))
(define-binary-branch-folder (u64-< type0 min0 max0 type1 min1 max1)
  (case (compare-exact-ranges min0 max0 min1 max1)
    ((<) (values #t #t))
    ((= >= >) (values #t #f))
    (else (values #f #f))))
(define-branch-folder-alias s64-< u64-<)
;; We currently cannot define branch folders for floating point
;; comparison ops like the commented one below because we can't prove
;; there are no nans involved.
;;
;; (define-branch-folder-alias f64-< <)

(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
  (if (type<=? (logior type0 type1) &exact-number)
      (case (compare-exact-ranges min0 max0 min1 max1)
        ((< <= =) (values #t #t))
        ((>) (values #t #f))
        (else (values #f #f)))
      (values #f #f)))

(define-unary-branch-folder* (u64-imm-= c type min max)
  (cond
   ((= c min max) (values #t #t))
   ((<= min c max) (values #f #f))
   (else (values #t #f))))
(define-branch-folder-alias s64-imm-= u64-imm-=)

(define-unary-branch-folder* (u64-imm-< c type min max)
  (cond
   ((< max c) (values #t #t))
   ((>= min c) (values #t #f))
   (else (values #f #f))))
(define-branch-folder-alias s64-imm-< u64-imm-<)

(define-unary-branch-folder* (imm-u64-< c type min max)
  (cond
   ((< c min) (values #t #t))
   ((>= c max) (values #t #f))
   (else (values #f #f))))
(define-branch-folder-alias imm-s64-< imm-u64-<)

(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
  (cond
   ((not (type<=? (logior type0 type1) &exact-number))
    (values #f #f))
   ((zero? (logand type0 type1))
    ;; If both values are exact but of different types, they are not
    ;; equal.
    (values #t #f))
   (else
    (case (compare-exact-ranges min0 max0 min1 max1)
      ((=) (values #t #t))
      ((< >) (values #t #f))
      (else (values #f #f))))))
(define-binary-branch-folder (u64-= type0 min0 max0 type1 min1 max1)
  (case (compare-exact-ranges min0 max0 min1 max1)
    ((=) (values #t #t))
    ((< >) (values #t #f))
    (else (values #f #f))))
(define-branch-folder-alias s64-= u64-=)




;; Convert e.g. rsh to rsh/immediate.

(define *primcall-macro-reducers* (make-hash-table))

(define-syntax-rule (define-primcall-macro-reducer op f)
  (hashq-set! *primcall-macro-reducers* 'op f))

(define-syntax-rule (define-unary-primcall-macro-reducer (op cps k src
                                                             arg type min max)
                      body ...)
  (define-primcall-macro-reducer op
    (lambda (cps k src param arg type min max)
      body ...)))

(define-syntax-rule (define-binary-primcall-macro-reducer
                      (op cps k src
                          arg0 type0 min0 max0
                          arg1 type1 min1 max1)
                      body ...)
  (define-primcall-macro-reducer op
    (lambda (cps k src param arg0 type0 min0 max0 arg1 type1 min1 max1)
      body ...)))

(define-binary-primcall-macro-reducer (mul cps k src
                                           arg0 type0 min0 max0
                                           arg1 type1 min1 max1)
  (cond
   ((and (type<=? type0 &exact-integer) (= min0 max0))
    (with-cps cps
      (build-term
        ($continue k src ($primcall 'mul/immediate min0 (arg1))))))
   ((and (type<=? type1 &exact-integer) (= min1 max1))
    (with-cps cps
      (build-term
        ($continue k src ($primcall 'mul/immediate min1 (arg0))))))
   (else
    (with-cps cps #f))))

(define-binary-primcall-macro-reducer (lsh cps k src
                                           arg0 type0 min0 max0
                                           arg1 type1 min1 max1)
  (cond
   ((= min1 max1)
    (with-cps cps
      (build-term
        ($continue k src ($primcall 'lsh/immediate min1 (arg0))))))
   (else
    (with-cps cps #f))))

(define-binary-primcall-macro-reducer (rsh cps k src
                                           arg0 type0 min0 max0
                                           arg1 type1 min1 max1)
  (cond
   ((= min1 max1)
    (with-cps cps
      (build-term
        ($continue k src ($primcall 'rsh/immediate min1 (arg0))))))
   (else
    (with-cps cps #f))))



;; Strength reduction.

(define *primcall-reducers* (make-hash-table))

(define-syntax-rule (define-primcall-reducer op f)
  (hashq-set! *primcall-reducers* 'op f))

(define-syntax-rule (define-unary-primcall-reducer (op cps k src param
                                                    arg type min max)
                      body ...)
  (define-primcall-reducer op
    (lambda (cps k src param arg type min max)
      body ...)))

(define-syntax-rule (define-binary-primcall-reducer (op cps k src param
                                                     arg0 type0 min0 max0
                                                     arg1 type1 min1 max1)
                      body ...)
  (define-primcall-reducer op
    (lambda (cps k src param arg0 type0 min0 max0 arg1 type1 min1 max1)
      body ...)))

(define-unary-primcall-reducer (mul/immediate cps k src constant
                                              arg type min max)
  (cond
   ((not (type<=? type &number))
    (with-cps cps #f))
   ((eqv? constant -1)
    ;; (* arg -1) -> (- 0 arg)
    (with-cps cps
      ($ (with-cps-constants ((zero 0))
           (build-term
             ($continue k src ($primcall 'sub #f (zero arg))))))))
   ((and (eqv? constant 0) (type<=? type &exact-number))
    ;; (* arg 0) -> 0 if arg is exact
    (with-cps cps
      (build-term ($continue k src ($const 0)))))
   ((eqv? constant 1)
    ;; (* arg 1) -> arg
    (with-cps cps
      (build-term ($continue k src ($values (arg))))))
   ((eqv? constant 2)
    ;; (* arg 2) -> (+ arg arg)
    (with-cps cps
      (build-term ($continue k src ($primcall 'add #f (arg arg))))))
   ((and (type<=? type &exact-integer)
         (positive? constant)
         (zero? (logand constant (1- constant))))
    ;; (* arg power-of-2) -> (lsh arg (log2 power-of-2))
    (let ((n (let lp ((bits 0) (constant constant))
               (if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
      (with-cps cps
        (build-term ($continue k src ($primcall 'lsh/immediate n (arg)))))))
   (else
    (with-cps cps #f))))

(define-binary-primcall-reducer (logbit? cps k src param
                                         arg0 type0 min0 max0
                                         arg1 type1 min1 max1)
  (define (compute-mask cps kmask src)
    (if (eq? min0 max0)
        (with-cps cps
          (build-term
            ($continue kmask src ($const (ash 1 min0)))))
        (with-cps cps
          ($ (with-cps-constants ((one 1))
               (letv n)
               (letk kn ($kargs ('n) (n)
                          ($continue kmask src
                            ($primcall 'lsh #f (one n)))))
               (build-term
                 ($continue kn src ($primcall 'untag-fixnum #f (arg0)))))))))
  (cond
   ((and (type<=? type0 &exact-integer)
         (<= 0 min0 (target-most-positive-fixnum))
         (<= 0 max0 (target-most-positive-fixnum)))
    (with-cps cps
      (letv mask res u64)
      (letk kt ($kargs () () ($continue k src ($const #t))))
      (letk kf ($kargs () () ($continue k src ($const #f))))
      (letk ku64 ($kargs (#f) (u64)
                   ($branch kt kf src 's64-imm-= 0 (u64))))
      (letk kand ($kargs (#f) (res)
                   ($continue ku64 src ($primcall 'untag-fixnum #f (res)))))
      (letk kmask ($kargs (#f) (mask)
                    ($continue kand src
                      ($primcall 'logand #f (mask arg1)))))
      ($ (compute-mask kmask src))))
   (else
    (with-cps cps #f))))

(define-unary-primcall-reducer (u64->scm cps k src constant arg type min max)
  (cond
   ((<= max (target-most-positive-fixnum))
    (with-cps cps
      (letv s64)
      (letk ks64 ($kargs ('s64) (s64)
                   ($continue k src
                     ($primcall 'tag-fixnum #f (s64)))))
      (build-term
        ($continue ks64 src
          ($primcall 'u64->s64 #f (arg))))))
   (else
    (with-cps cps #f))))

(define-unary-primcall-reducer (s64->scm cps k src constant arg type min max)
  (cond
   ((<= (target-most-negative-fixnum) min max (target-most-positive-fixnum))
    (with-cps cps
      (build-term
        ($continue k src
          ($primcall 'tag-fixnum #f (arg))))))
   (else
    (with-cps cps #f))))

(define-unary-primcall-reducer (scm->s64 cps k src constant arg type min max)
  (cond
   ((and (type<=? type &exact-integer)
         (<= (target-most-negative-fixnum) min max (target-most-positive-fixnum)))
    (with-cps cps
      (build-term
        ($continue k src
          ($primcall 'untag-fixnum #f (arg))))))
   (else
    (with-cps cps #f))))

(define-unary-primcall-reducer (scm->u64 cps k src constant arg type min max)
  (cond
   ((and (type<=? type &exact-integer)
         (<= 0 min max (target-most-positive-fixnum)))
    (with-cps cps
      (letv s64)
      (letk ks64 ($kargs ('s64) (s64)
                   ($continue k src
                     ($primcall 's64->u64 #f (s64)))))
      (build-term
        ($continue ks64 src
          ($primcall 'untag-fixnum #f (arg))))))
   (else
    (with-cps cps #f))))



;;

(define (local-type-fold start end cps)
  (define (scalar-value type val)
    (cond
     ((eqv? type &fixnum) val)
     ((eqv? type &bignum) val)
     ((eqv? type &flonum) (exact->inexact val))
     ((eqv? type &char) (integer->char val))
     ((eqv? type &special-immediate)
      (cond
       ((eqv? val &null) '())
       ((eqv? val &nil) #nil)
       ((eqv? val &false) #f)
       ((eqv? val &true) #t)
       ((eqv? val &unspecified) *unspecified*)
       ;; FIXME: &undefined here
       ((eqv? val &eof) the-eof-object)
       (else (error "unhandled immediate" val))))
     (else (error "unhandled type" type val))))
  (let ((types (infer-types cps start)))
    (define (fold-primcall cps label names vars k src op param args def)
      (call-with-values (lambda () (lookup-post-type types label def 0))
        (lambda (type min max)
          (and (not (zero? type))
               (zero? (logand type (1- type)))
               (zero? (logand type (lognot &scalar-types)))
               (eqv? min max)
               (let ((val (scalar-value type min)))
                 ;; (pk 'folded src op args val)
                 (with-cps cps
                   (letv v*)
                   (letk k* ($kargs (#f) (v*)
                              ($continue k src ($const val))))
                   ;; Rely on DCE to elide this expression, if
                   ;; possible.
                   (setk label
                         ($kargs names vars
                           ($continue k* src ($primcall op param args))))))))))
    (define (transform-primcall f cps label names vars k src op param args)
      (and f
           (match args
             ((arg0)
              (call-with-values (lambda () (lookup-pre-type types label arg0))
                (lambda (type0 min0 max0)
                  (call-with-values (lambda ()
                                      (f cps k src param arg0 type0 min0 max0))
                    (lambda (cps term)
                      (and term
                           (with-cps cps
                             (setk label ($kargs names vars ,term)))))))))
             ((arg0 arg1)
              (call-with-values (lambda () (lookup-pre-type types label arg0))
                (lambda (type0 min0 max0)
                  (call-with-values (lambda () (lookup-pre-type types label arg1))
                    (lambda (type1 min1 max1)
                      (call-with-values (lambda ()
                                          (f cps k src param arg0 type0 min0 max0
                                             arg1 type1 min1 max1))
                        (lambda (cps term)
                          (and term
                               (with-cps cps
                                 (setk label ($kargs names vars ,term)))))))))))
             (_ #f))))
    (define (reduce-primcall cps label names vars k src op param args)
      (cond
       ((transform-primcall (hashq-ref *primcall-macro-reducers* op)
                            cps label names vars k src op param args)
        => (lambda (cps)
             (match (intmap-ref cps label)
               (($ $kargs names vars
                   ($ $continue k src ($ $primcall op param args)))
                (reduce-primcall cps label names vars k src op param args)))))
       ((transform-primcall (hashq-ref *primcall-reducers* op)
                            cps label names vars k src op param args))
       (else cps)))
    (define (fold-unary-branch cps label names vars kf kt src op param arg)
      (and=>
       (hashq-ref *branch-folders* op)
       (lambda (folder)
         (call-with-values (lambda () (lookup-pre-type types label arg))
           (lambda (type min max)
             (call-with-values (lambda () (folder param type min max))
               (lambda (f? v)
                 ;; (when f? (pk 'folded-unary-branch label op arg v))
                 (and f?
                      (with-cps cps
                        (setk label
                              ($kargs names vars
                                ($continue (if v kt kf) src
                                  ($values ())))))))))))))
    (define (fold-binary-branch cps label names vars kf kt src op param arg0 arg1)
      (and=>
       (hashq-ref *branch-folders* op)
       (lambda (folder)
         (call-with-values (lambda () (lookup-pre-type types label arg0))
           (lambda (type0 min0 max0)
             (call-with-values (lambda () (lookup-pre-type types label arg1))
               (lambda (type1 min1 max1)
                 (call-with-values (lambda ()
                                     (folder param type0 min0 max0 type1 min1 max1))
                   (lambda (f? v)
                     ;; (when f? (pk 'folded-binary-branch label op arg0 arg1 v))
                     (and f?
                          (with-cps cps
                            (setk label
                                  ($kargs names vars
                                    ($continue (if v kt kf) src
                                      ($values ())))))))))))))))
    (define (visit-primcall cps label names vars k src op param args)
      ;; We might be able to fold primcalls that define a value.
      (match (intmap-ref cps k)
        (($ $kargs (_) (def))
         (or (fold-primcall cps label names vars k src op param args def)
             (reduce-primcall cps label names vars k src op param args)))
        (_
         (reduce-primcall cps label names vars k src op param args))))
    (define (visit-branch cps label names vars kf kt src op param args)
      ;; We might be able to fold primcalls that branch.
      (match args
        ((x)
         (or (fold-unary-branch cps label names vars kf kt src op param x)
             cps))
        ((x y)
         (or (fold-binary-branch cps label names vars kf kt src op param x y)
             cps))))
    (let lp ((label start) (cps cps))
      (if (<= label end)
          (lp (1+ label)
              (match (intmap-ref cps label)
                (($ $kargs names vars ($ $continue k src
                                         ($ $primcall op param args)))
                 (visit-primcall cps label names vars k src op param args))
                (($ $kargs names vars ($ $branch kf kt src op param args))
                 (visit-branch cps label names vars kf kt src op param args))
                (_ cps)))
          cps))))

(define (fold-functions-in-renumbered-program f conts seed)
  (let* ((conts (persistent-intmap conts))
         (end (1+ (intmap-prev conts))))
    (let lp ((label 0) (seed seed))
      (if (eqv? label end)
          seed
          (match (intmap-ref conts label)
            (($ $kfun src meta self tail clause)
             (lp (1+ tail) (f label tail seed))))))))

(define (type-fold conts)
  ;; Type analysis wants a program whose labels are sorted.
  (let ((conts (renumber conts)))
    (with-fresh-name-state conts
      (persistent-intmap
       (fold-functions-in-renumbered-program local-type-fold conts conts)))))