module/language/cps/type-fold.scm

   1 ;;; Abstract constant folding on CPS
   2 ;;; Copyright (C) 2014 Free Software Foundation, Inc.
   3 ;;;
   4 ;;; This library is free software: you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU Lesser General Public License as
   6 ;;; published by the Free Software Foundation, either version 3 of the
   7 ;;; License, or (at your option) any later version.
   8 ;;;
   9 ;;; This library is distributed in the hope that it will be useful, but
  10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; Lesser General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Lesser General Public
  15 ;;; License along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 ;;; Commentary:
  19 ;;;
  20 ;;; This pass uses the abstract interpretation provided by type analysis
  21 ;;; to fold constant values and type predicates.  It is most profitably
  22 ;;; run after CSE, to take advantage of scalar replacement.
  23 ;;;
  24 ;;; Code:
  25
  26 (define-module (language cps type-fold)
  27   #:use-module (ice-9 match)
  28   #:use-module (language cps)
  29   #:use-module (language cps dfg)
  30   #:use-module (language cps renumber)
  31   #:use-module (language cps types)
  32   #:export (type-fold))
  33
  34 (define &scalar-types
  35   (logior &exact-integer &flonum &char &unspecified &boolean &nil &null))
  36
  37 (define *branch-folders* (make-hash-table))
  38
  39 (define-syntax-rule (define-branch-folder name f)
  40   (hashq-set! *branch-folders* 'name f))
  41
  42 (define-syntax-rule (define-branch-folder-alias to from)
  43   (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))
  44
  45 (define-syntax-rule (define-unary-branch-folder (name arg min max) body ...)
  46   (define-branch-folder name (lambda (arg min max) body ...)))
  47
  48 (define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0
  49                                                        arg1 min1 max1)
  50                       body ...)
  51   (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...)))
  52
  53 (define-syntax-rule (define-unary-type-predicate-folder name &type)
  54   (define-unary-branch-folder (name type min max)
  55     (let ((type* (logand type &type)))
  56       (cond
  57        ((zero? type*) (values #t #f))
  58        ((eqv? type type*) (values #t #t))
  59        (else (values #f #f))))))
  60
  61 ;; All the cases that are in compile-bytecode.
  62 (define-unary-type-predicate-folder pair? &pair)
  63 (define-unary-type-predicate-folder null? &null)
  64 (define-unary-type-predicate-folder nil? &nil)
  65 (define-unary-type-predicate-folder symbol? &symbol)
  66 (define-unary-type-predicate-folder variable? &box)
  67 (define-unary-type-predicate-folder vector? &vector)
  68 (define-unary-type-predicate-folder struct? &struct)
  69 (define-unary-type-predicate-folder string? &string)
  70 (define-unary-type-predicate-folder number? &number)
  71 (define-unary-type-predicate-folder char? &char)
  72
  73 (define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1)
  74   (cond
  75    ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0))
  76     (values #t #f))
  77    ((and (eqv? type0 type1)
  78          (eqv? min0 min1 max0 max1)
  79          (zero? (logand type0 (1- type0)))
  80          (not (zero? (logand type0 &scalar-types))))
  81     (values #t #t))
  82    (else
  83     (values #f #f))))
  84 (define-branch-folder-alias eqv? eq?)
  85 (define-branch-folder-alias equal? eq?)
  86
  87 (define (compare-ranges type0 min0 max0 type1 min1 max1)
  88   (and (zero? (logand (logior type0 type1) (lognot &real)))
  89        (cond ((< max0 min1) '<)
  90              ((> min0 max1) '>)
  91              ((= min0 max0 min1 max1) '=)
  92              ((<= max0 min1) '<=)
  93              ((>= min0 max1) '>=)
  94              (else #f))))
  95
  96 (define-binary-branch-folder (< type0 min0 max0 type1 min1 max1)
  97   (case (compare-ranges type0 min0 max0 type1 min1 max1)
  98     ((<) (values #t #t))
  99     ((= >= >) (values #t #f))
 100     (else (values #f #f))))
 101
 102 (define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
 103   (case (compare-ranges type0 min0 max0 type1 min1 max1)
 104     ((< <= =) (values #t #t))
 105     ((>) (values #t #f))
 106     (else (values #f #f))))
 107
 108 (define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
 109   (case (compare-ranges type0 min0 max0 type1 min1 max1)
 110     ((=) (values #t #t))
 111     ((< >) (values #t #f))
 112     (else (values #f #f))))
 113
 114 (define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
 115   (case (compare-ranges type0 min0 max0 type1 min1 max1)
 116     ((> >= =) (values #t #t))
 117     ((<) (values #t #f))
 118     (else (values #f #f))))
 119
 120 (define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
 121   (case (compare-ranges type0 min0 max0 type1 min1 max1)
 122     ((>) (values #t #t))
 123     ((= <= <) (values #t #f))
 124     (else (values #f #f))))
 125
 126 (define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
 127   (define (logand-min a b)
 128     (if (< a b 0)
 129         (min a b)
 130         0))
 131   (define (logand-max a b)
 132     (if (< a b 0)
 133         0
 134         (max a b)))
 135   (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer))
 136       (values #t (logtest min0 min1))
 137       (values #f #f)))
 138
 139 (define (compute-folded fun dfg min-label min-var)
 140   (define (scalar-value type val)
 141     (cond
 142      ((eqv? type &exact-integer) val)
 143      ((eqv? type &flonum) (exact->inexact val))
 144      ((eqv? type &char) (integer->char val))
 145      ((eqv? type &unspecified) *unspecified*)
 146      ((eqv? type &boolean) (not (zero? val)))
 147      ((eqv? type &nil) #nil)
 148      ((eqv? type &null) '())
 149      (else (error "unhandled type" type val))))
 150   (let* ((typev (infer-types fun dfg))
 151          (label-count ((make-local-cont-folder label-count)
 152                        (lambda (k cont label-count) (1+ label-count))
 153                        fun 0))
 154          (folded? (make-bitvector label-count #f))
 155          (folded-values (make-vector label-count #f)))
 156     (define (label->idx label) (- label min-label))
 157     (define (var->idx var) (- var min-var))
 158     (define (maybe-fold-value! label name def)
 159       (call-with-values (lambda () (lookup-post-type typev label def 0))
 160         (lambda (type min max)
 161           (when (and (not (zero? type))
 162                      (zero? (logand type (1- type)))
 163                      (zero? (logand type (lognot &scalar-types)))
 164                      (eqv? min max))
 165             (bitvector-set! folded? (label->idx label) #t)
 166             (vector-set! folded-values (label->idx label)
 167                          (scalar-value type min))))))
 168     (define (maybe-fold-unary-branch! label name arg)
 169       (let* ((folder (hashq-ref *branch-folders* name)))
 170         (when folder
 171           (call-with-values (lambda () (lookup-pre-type typev label arg))
 172             (lambda (type min max)
 173               (call-with-values (lambda () (folder type min max))
 174                 (lambda (f? v)
 175                   (bitvector-set! folded? (label->idx label) f?)
 176                   (vector-set! folded-values (label->idx label) v))))))))
 177     (define (maybe-fold-binary-branch! label name arg0 arg1)
 178       (let* ((folder (hashq-ref *branch-folders* name)))
 179         (when folder
 180           (call-with-values (lambda () (lookup-pre-type typev label arg0))
 181             (lambda (type0 min0 max0)
 182               (call-with-values (lambda () (lookup-pre-type typev label arg1))
 183                 (lambda (type1 min1 max1)
 184                   (call-with-values (lambda ()
 185                                       (folder type0 min0 max0 type1 min1 max1))
 186                     (lambda (f? v)
 187                       (bitvector-set! folded? (label->idx label) f?)
 188                       (vector-set! folded-values (label->idx label) v))))))))))
 189     (define (visit-cont cont)
 190       (match cont
 191         (($ $cont label ($ $kargs _ _ body))
 192          (visit-term body label))
 193         (($ $cont label ($ $kclause arity body alternate))
 194          (visit-cont body)
 195          (visit-cont alternate))
 196         (_ #f)))
 197     (define (visit-term term label)
 198       (match term
 199         (($ $letk conts body)
 200          (for-each visit-cont conts)
 201          (visit-term body label))
 202         (($ $letrec _ _ _ body)
 203          (visit-term body label))
 204         (($ $continue k src ($ $primcall name args))
 205          ;; We might be able to fold primcalls that define a value.
 206          (match (lookup-cont k dfg)
 207            (($ $kargs (_) (def))
 208             ;(pk 'maybe-fold-value src name args)
 209             (maybe-fold-value! label name def))
 210            (_ #f)))
 211         (($ $continue kf src ($ $branch kt ($ $primcall name args)))
 212          ;; We might be able to fold primcalls that branch.
 213          ;(pk 'maybe-fold-branch label src name args)
 214          (match args
 215            ((arg)
 216             (maybe-fold-unary-branch! label name arg))
 217            ((arg0 arg1)
 218             (maybe-fold-binary-branch! label name arg0 arg1))))
 219         (_ #f)))
 220     (when typev
 221       (match fun
 222         (($ $cont kfun ($ $kfun src meta self tail clause))
 223          (visit-cont clause))))
 224     (values folded? folded-values)))
 225
 226 (define (fold-constants* fun dfg)
 227   (match fun
 228     (($ $cont min-label ($ $kfun _ _ min-var))
 229      (call-with-values (lambda () (compute-folded fun dfg min-label min-var))
 230        (lambda (folded? folded-values)
 231          (define (label->idx label) (- label min-label))
 232          (define (var->idx var) (- var min-var))
 233          (define (visit-cont cont)
 234            (rewrite-cps-cont cont
 235              (($ $cont label ($ $kargs names syms body))
 236               (label ($kargs names syms ,(visit-term body label))))
 237              (($ $cont label ($ $kclause arity body alternate))
 238               (label ($kclause ,arity ,(visit-cont body)
 239                                ,(and alternate (visit-cont alternate)))))
 240              (_ ,cont)))
 241          (define (visit-term term label)
 242            (rewrite-cps-term term
 243              (($ $letk conts body)
 244               ($letk ,(map visit-cont conts)
 245                 ,(visit-term body label)))
 246              (($ $letrec names vars funs body)
 247               ($letrec names vars (map visit-fun funs)
 248                 ,(visit-term body label)))
 249              (($ $continue k src (and fun ($ $fun)))
 250               ($continue k src ,(visit-fun fun)))
 251              (($ $continue k src (and primcall ($ $primcall)))
 252               ,(if (bitvector-ref folded? (label->idx label))
 253                    (let ((val (vector-ref folded-values (label->idx label))))
 254                      ;; Uncomment for debugging.
 255                      ;; (pk 'folded src primcall val)
 256                      (let-fresh (k*) (v*)
 257                        ;; Rely on DCE to elide this expression, if
 258                        ;; possible.
 259                        (build-cps-term
 260                          ($letk ((k* ($kargs (#f) (v*)
 261                                        ($continue k src ($const val)))))
 262                            ($continue k* src ,primcall)))))
 263                    term))
 264              (($ $continue kf src ($ $branch kt ($ $primcall)))
 265               ,(if (bitvector-ref folded? (label->idx label))
 266                    ;; Folded branch.
 267                    (let ((val (vector-ref folded-values (label->idx label))))
 268                      (build-cps-term
 269                        ($continue (if val kt kf) src ($values ()))))
 270                    term))
 271              (_ ,term)))
 272          (define (visit-fun fun)
 273            (rewrite-cps-exp fun
 274              (($ $fun free body)
 275               ($fun free ,(fold-constants* body dfg)))))
 276          (rewrite-cps-cont fun
 277            (($ $cont kfun ($ $kfun src meta self tail clause))
 278             (kfun ($kfun src meta self ,tail ,(visit-cont clause))))))))))
 279
 280 (define (type-fold fun)
 281   (let* ((fun (renumber fun))
 282          (dfg (compute-dfg fun)))
 283     (with-fresh-name-state-from-dfg dfg
 284       (fold-constants* fun dfg))))