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