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   #:use-module (system base target)
  33   #:export (type-fold))
  34
  35
  36 \f
  37
  38 ;; Branch folders.
  39
  40 (define &scalar-types
  41   (logior &exact-integer &flonum &char &unspecified &false &true &nil &null))
  42
  43 (define *branch-folders* (make-hash-table))
  44
  45 (define-syntax-rule (define-branch-folder name f)
  46   (hashq-set! *branch-folders* 'name f))
  47
  48 (define-syntax-rule (define-branch-folder-alias to from)
  49   (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))
  50
  51 (define-syntax-rule (define-unary-branch-folder (name arg min max) body ...)
  52   (define-branch-folder name (lambda (arg min max) body ...)))
  53
  54 (define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0
  55                                                        arg1 min1 max1)
  56                       body ...)
  57   (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...)))
  58
  59 (define-syntax-rule (define-unary-type-predicate-folder name &type)
  60   (define-unary-branch-folder (name type min max)
  61     (let ((type* (logand type &type)))
  62       (cond
  63        ((zero? type*) (values #t #f))
  64        ((eqv? type type*) (values #t #t))
  65        (else (values #f #f))))))
  66
  67 ;; All the cases that are in compile-bytecode.
  68 (define-unary-type-predicate-folder pair? &pair)
  69 (define-unary-type-predicate-folder null? &null)
  70 (define-unary-type-predicate-folder nil? &nil)
  71 (define-unary-type-predicate-folder symbol? &symbol)
  72 (define-unary-type-predicate-folder variable? &box)
  73 (define-unary-type-predicate-folder vector? &vector)
  74 (define-unary-type-predicate-folder struct? &struct)
  75 (define-unary-type-predicate-folder string? &string)
  76 (define-unary-type-predicate-folder number? &number)
  77 (define-unary-type-predicate-folder char? &char)
  78
  79 (define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1)
  80   (cond
  81    ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0))
  82     (values #t #f))
  83    ((and (eqv? type0 type1)
  84          (eqv? min0 min1 max0 max1)
  85          (zero? (logand type0 (1- type0)))
  86          (not (zero? (logand type0 &scalar-types))))
  87     (values #t #t))
  88    (else
  89     (values #f #f))))
  90 (define-branch-folder-alias eqv? eq?)
  91 (define-branch-folder-alias equal? eq?)
  92
  93 (define (compare-ranges type0 min0 max0 type1 min1 max1)
  94   (and (zero? (logand (logior type0 type1) (lognot &real)))
  95        (cond ((< max0 min1) '<)
  96              ((> min0 max1) '>)
  97              ((= min0 max0 min1 max1) '=)
  98              ((<= max0 min1) '<=)
  99              ((>= min0 max1) '>=)
 100              (else #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 (> type0 min0 max0 type1 min1 max1)
 127   (case (compare-ranges type0 min0 max0 type1 min1 max1)
 128     ((>) (values #t #t))
 129     ((= <= <) (values #t #f))
 130     (else (values #f #f))))
 131
 132 (define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
 133   (define (logand-min a b)
 134     (if (< a b 0)
 135         (min a b)
 136         0))
 137   (define (logand-max a b)
 138     (if (< a b 0)
 139         0
 140         (max a b)))
 141   (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer))
 142       (values #t (logtest min0 min1))
 143       (values #f #f)))
 144
 145
 146 \f
 147
 148 ;; Strength reduction.
 149
 150 (define *primcall-reducers* (make-hash-table))
 151
 152 (define-syntax-rule (define-primcall-reducer name f)
 153   (hashq-set! *primcall-reducers* 'name f))
 154
 155 (define-syntax-rule (define-unary-primcall-reducer (name dfg k src
 156                                                          arg type min max)
 157                       body ...)
 158   (define-primcall-reducer name
 159     (lambda (dfg k src arg type min max) body ...)))
 160
 161 (define-syntax-rule (define-binary-primcall-reducer (name dfg k src
 162                                                           arg0 type0 min0 max0
 163                                                           arg1 type1 min1 max1)
 164                       body ...)
 165   (define-primcall-reducer name
 166     (lambda (dfg k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...)))
 167
 168 (define-binary-primcall-reducer (mul dfg k src
 169                                      arg0 type0 min0 max0
 170                                      arg1 type1 min1 max1)
 171   (define (negate arg)
 172     (let-fresh (kzero) (zero)
 173       (build-cps-term
 174         ($letk ((kzero ($kargs (#f) (zero)
 175                          ($continue k src ($primcall 'sub (zero arg))))))
 176           ($continue kzero src ($const 0))))))
 177   (define (zero)
 178     (build-cps-term ($continue k src ($const 0))))
 179   (define (identity arg)
 180     (build-cps-term ($continue k src ($values (arg)))))
 181   (define (double arg)
 182     (build-cps-term ($continue k src ($primcall 'add (arg arg)))))
 183   (define (power-of-two constant arg)
 184     (let ((n (let lp ((bits 0) (constant constant))
 185                (if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
 186       (let-fresh (kbits) (bits)
 187         (build-cps-term
 188           ($letk ((kbits ($kargs (#f) (bits)
 189                            ($continue k src ($primcall 'ash (arg bits))))))
 190             ($continue kbits src ($const n)))))))
 191   (define (mul/constant constant constant-type arg arg-type)
 192     (and (or (= constant-type &exact-integer) (= constant-type arg-type))
 193          (case constant
 194            ;; (* arg -1) -> (- 0 arg)
 195            ((-1) (negate arg))
 196            ;; (* arg 0) -> 0 if arg is not a flonum or complex
 197            ((0) (and (= constant-type &exact-integer)
 198                      (zero? (logand arg-type
 199                                     (lognot (logior &flonum &complex))))
 200                      (zero)))
 201            ;; (* arg 1) -> arg
 202            ((1) (identity arg))
 203            ;; (* arg 2) -> (+ arg arg)
 204            ((2) (double arg))
 205            (else (and (= constant-type arg-type &exact-integer)
 206                       (positive? constant)
 207                       (zero? (logand constant (1- constant)))
 208                       (power-of-two constant arg))))))
 209   (cond
 210    ((logtest (logior type0 type1) (lognot &number)) #f)
 211    ((= min0 max0) (mul/constant min0 type0 arg1 type1))
 212    ((= min1 max1) (mul/constant min1 type1 arg0 type0))
 213    (else #f)))
 214
 215 (define-binary-primcall-reducer (logbit? dfg k src
 216                                          arg0 type0 min0 max0
 217                                          arg1 type1 min1 max1)
 218   (define (convert-to-logtest bool-term)
 219     (let-fresh (kt kf kmask kbool) (mask bool)
 220      (build-cps-term
 221        ($letk ((kt ($kargs () ()
 222                      ($continue kbool src ($const #t))))
 223                (kf ($kargs () ()
 224                      ($continue kbool src ($const #f))))
 225                (kbool ($kargs (#f) (bool)
 226                         ,(bool-term bool)))
 227                (kmask ($kargs (#f) (mask)
 228                         ($continue kf src
 229                           ($branch kt ($primcall 'logtest (mask arg1)))))))
 230          ,(if (eq? min0 max0)
 231               ($continue kmask src ($const (ash 1 min0)))
 232               (let-fresh (kone) (one)
 233                 (build-cps-term
 234                   ($letk ((kone ($kargs (#f) (one)
 235                                   ($continue kmask src
 236                                     ($primcall 'ash (one arg0))))))
 237                     ($continue kone src ($const 1))))))))))
 238   ;; Hairiness because we are converting from a primcall with unknown
 239   ;; arity to a branching primcall.
 240   (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3)))
 241     (and (= type0 &exact-integer)
 242          (<= 0 min0 positive-fixnum-bits)
 243          (<= 0 max0 positive-fixnum-bits)
 244          (match (lookup-cont k dfg)
 245            (($ $kreceive arity kargs)
 246             (match arity
 247               (($ $arity (_) () (not #f) () #f)
 248                (convert-to-logtest
 249                 (lambda (bool)
 250                   (let-fresh (knil) (nil)
 251                     (build-cps-term
 252                       ($letk ((knil ($kargs (#f) (nil)
 253                                       ($continue kargs src
 254                                         ($values (bool nil))))))
 255                         ($continue knil src ($const '()))))))))
 256               (_
 257                (convert-to-logtest
 258                 (lambda (bool)
 259                   (build-cps-term
 260                     ($continue k src ($primcall 'values (bool)))))))))
 261            (($ $ktail)
 262             (convert-to-logtest
 263              (lambda (bool)
 264                (build-cps-term
 265                  ($continue k src ($primcall 'return (bool)))))))))))
 266
 267
 268 \f
 269
 270 ;;
 271
 272 (define (fold-and-reduce fun dfg min-label min-var)
 273   (define (scalar-value type val)
 274     (cond
 275      ((eqv? type &exact-integer) val)
 276      ((eqv? type &flonum) (exact->inexact val))
 277      ((eqv? type &char) (integer->char val))
 278      ((eqv? type &unspecified) *unspecified*)
 279      ((eqv? type &false) #f)
 280      ((eqv? type &true) #t)
 281      ((eqv? type &nil) #nil)
 282      ((eqv? type &null) '())
 283      (else (error "unhandled type" type val))))
 284   (let* ((typev (infer-types fun dfg))
 285          (label-count ((make-local-cont-folder label-count)
 286                        (lambda (k cont label-count) (1+ label-count))
 287                        fun 0))
 288          (folded? (make-bitvector label-count #f))
 289          (folded-values (make-vector label-count #f))
 290          (reduced-terms (make-vector label-count #f)))
 291     (define (label->idx label) (- label min-label))
 292     (define (var->idx var) (- var min-var))
 293     (define (maybe-reduce-primcall! label k src name args)
 294       (let* ((reducer (hashq-ref *primcall-reducers* name)))
 295         (when reducer
 296           (vector-set!
 297            reduced-terms
 298            (label->idx label)
 299            (match args
 300              ((arg0)
 301               (call-with-values (lambda () (lookup-pre-type typev label arg0))
 302                 (lambda (type0 min0 max0)
 303                   (reducer dfg k src arg0 type0 min0 max0))))
 304              ((arg0 arg1)
 305               (call-with-values (lambda () (lookup-pre-type typev label arg0))
 306                 (lambda (type0 min0 max0)
 307                   (call-with-values (lambda () (lookup-pre-type typev label arg1))
 308                     (lambda (type1 min1 max1)
 309                       (reducer dfg k src arg0 type0 min0 max0
 310                                arg1 type1 min1 max1))))))
 311              (_ #f))))))
 312     (define (maybe-fold-value! label name def)
 313       (call-with-values (lambda () (lookup-post-type typev label def 0))
 314         (lambda (type min max)
 315           (cond
 316            ((and (not (zero? type))
 317                  (zero? (logand type (1- type)))
 318                  (zero? (logand type (lognot &scalar-types)))
 319                  (eqv? min max))
 320             (bitvector-set! folded? (label->idx label) #t)
 321             (vector-set! folded-values (label->idx label)
 322                          (scalar-value type min))
 323             #t)
 324            (else #f)))))
 325     (define (maybe-fold-unary-branch! label name arg)
 326       (let* ((folder (hashq-ref *branch-folders* name)))
 327         (when folder
 328           (call-with-values (lambda () (lookup-pre-type typev label arg))
 329             (lambda (type min max)
 330               (call-with-values (lambda () (folder type min max))
 331                 (lambda (f? v)
 332                   (bitvector-set! folded? (label->idx label) f?)
 333                   (vector-set! folded-values (label->idx label) v))))))))
 334     (define (maybe-fold-binary-branch! label name arg0 arg1)
 335       (let* ((folder (hashq-ref *branch-folders* name)))
 336         (when folder
 337           (call-with-values (lambda () (lookup-pre-type typev label arg0))
 338             (lambda (type0 min0 max0)
 339               (call-with-values (lambda () (lookup-pre-type typev label arg1))
 340                 (lambda (type1 min1 max1)
 341                   (call-with-values (lambda ()
 342                                       (folder type0 min0 max0 type1 min1 max1))
 343                     (lambda (f? v)
 344                       (bitvector-set! folded? (label->idx label) f?)
 345                       (vector-set! folded-values (label->idx label) v))))))))))
 346     (define (visit-cont cont)
 347       (match cont
 348         (($ $cont label ($ $kargs _ _ body))
 349          (visit-term body label))
 350         (($ $cont label ($ $kclause arity body alternate))
 351          (visit-cont body)
 352          (visit-cont alternate))
 353         (_ #f)))
 354     (define (visit-term term label)
 355       (match term
 356         (($ $letk conts body)
 357          (for-each visit-cont conts)
 358          (visit-term body label))
 359         (($ $letrec _ _ _ body)
 360          (visit-term body label))
 361         (($ $continue k src ($ $primcall name args))
 362          ;; We might be able to fold primcalls that define a value.
 363          (match (lookup-cont k dfg)
 364            (($ $kargs (_) (def))
 365             ;(pk 'maybe-fold-value src name args)
 366             (unless (maybe-fold-value! label name def)
 367               (maybe-reduce-primcall! label k src name args)))
 368            (_
 369             (maybe-reduce-primcall! label k src name args))))
 370         (($ $continue kf src ($ $branch kt ($ $primcall name args)))
 371          ;; We might be able to fold primcalls that branch.
 372          ;(pk 'maybe-fold-branch label src name args)
 373          (match args
 374            ((arg)
 375             (maybe-fold-unary-branch! label name arg))
 376            ((arg0 arg1)
 377             (maybe-fold-binary-branch! label name arg0 arg1))))
 378         (_ #f)))
 379     (when typev
 380       (match fun
 381         (($ $cont kfun ($ $kfun src meta self tail clause))
 382          (visit-cont clause))))
 383     (values folded? folded-values reduced-terms)))
 384
 385 (define (fold-constants* fun dfg)
 386   (match fun
 387     (($ $cont min-label ($ $kfun _ _ min-var))
 388      (call-with-values (lambda () (fold-and-reduce fun dfg min-label min-var))
 389        (lambda (folded? folded-values reduced-terms)
 390          (define (label->idx label) (- label min-label))
 391          (define (var->idx var) (- var min-var))
 392          (define (visit-cont cont)
 393            (rewrite-cps-cont cont
 394              (($ $cont label ($ $kargs names syms body))
 395               (label ($kargs names syms ,(visit-term body label))))
 396              (($ $cont label ($ $kclause arity body alternate))
 397               (label ($kclause ,arity ,(visit-cont body)
 398                                ,(and alternate (visit-cont alternate)))))
 399              (_ ,cont)))
 400          (define (visit-term term label)
 401            (rewrite-cps-term term
 402              (($ $letk conts body)
 403               ($letk ,(map visit-cont conts)
 404                 ,(visit-term body label)))
 405              (($ $letrec names vars funs body)
 406               ($letrec names vars (map visit-fun funs)
 407                 ,(visit-term body label)))
 408              (($ $continue k src (and fun ($ $fun)))
 409               ($continue k src ,(visit-fun fun)))
 410              (($ $continue k src (and primcall ($ $primcall name args)))
 411               ,(cond
 412                 ((bitvector-ref folded? (label->idx label))
 413                  (let ((val (vector-ref folded-values (label->idx label))))
 414                    ;; Uncomment for debugging.
 415                    ;; (pk 'folded src primcall val)
 416                    (let-fresh (k*) (v*)
 417                      ;; Rely on DCE to elide this expression, if
 418                      ;; possible.
 419                      (build-cps-term
 420                        ($letk ((k* ($kargs (#f) (v*)
 421                                      ($continue k src ($const val)))))
 422                          ($continue k* src ,primcall))))))
 423                 (else
 424                  (or (vector-ref reduced-terms (label->idx label))
 425                      term))))
 426              (($ $continue kf src ($ $branch kt ($ $primcall)))
 427               ,(if (bitvector-ref folded? (label->idx label))
 428                    ;; Folded branch.
 429                    (let ((val (vector-ref folded-values (label->idx label))))
 430                      (build-cps-term
 431                        ($continue (if val kt kf) src ($values ()))))
 432                    term))
 433              (_ ,term)))
 434          (define (visit-fun fun)
 435            (rewrite-cps-exp fun
 436              (($ $fun free body)
 437               ($fun free ,(fold-constants* body dfg)))))
 438          (rewrite-cps-cont fun
 439            (($ $cont kfun ($ $kfun src meta self tail clause))
 440             (kfun ($kfun src meta self ,tail ,(visit-cont clause))))))))))
 441
 442 (define (type-fold fun)
 443   (let* ((fun (renumber fun))
 444          (dfg (compute-dfg fun)))
 445     (with-fresh-name-state-from-dfg dfg
 446       (fold-constants* fun dfg))))