[bpt/guile.git] / module / language / cps / type-fold.scm

;;; Abstract constant folding on CPS
;;; Copyright (C) 2014 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 dfg)
  #:use-module (language cps renumber)
  #:use-module (language cps types)
  #:export (type-fold))

(define &scalar-types
  (logior &exact-integer &flonum &char &unspecified &boolean &nil &null))

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

(define-syntax-rule (define-branch-folder name f)
  (hashq-set! *branch-folders* 'name 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 (name arg min max) body ...)
  (define-branch-folder name (lambda (arg min max) body ...)))

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

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

;; All the cases that are in compile-bytecode.
(define-unary-type-predicate-folder pair? &pair)
(define-unary-type-predicate-folder null? &null)
(define-unary-type-predicate-folder nil? &nil)
(define-unary-type-predicate-folder symbol? &symbol)
(define-unary-type-predicate-folder variable? &box)
(define-unary-type-predicate-folder vector? &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-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 eqv? eq?)
(define-branch-folder-alias equal? eq?)

(define (compare-ranges type0 min0 max0 type1 min1 max1)
  (and (zero? (logand (logior type0 type1) (lognot &real)))
       (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)
  (case (compare-ranges type0 min0 max0 type1 min1 max1)
    ((<) (values #t #t))
    ((= >= >) (values #t #f))
    (else (values #f #f))))

(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
  (case (compare-ranges type0 min0 max0 type1 min1 max1)
    ((< <= =) (values #t #t))
    ((>) (values #t #f))
    (else (values #f #f))))

(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
  (case (compare-ranges type0 min0 max0 type1 min1 max1)
    ((=) (values #t #t))
    ((< >) (values #t #f))
    (else (values #f #f))))

(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
  (case (compare-ranges type0 min0 max0 type1 min1 max1)
    ((> >= =) (values #t #t))
    ((<) (values #t #f))
    (else (values #f #f))))

(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
  (case (compare-ranges type0 min0 max0 type1 min1 max1)
    ((>) (values #t #t))
    ((= <= <) (values #t #f))
    (else (values #f #f))))

(define (compute-folded fun dfg min-label min-var)
  (define (scalar-value type val)
    (cond
     ((eqv? type &exact-integer) val)
     ((eqv? type &flonum) (exact->inexact val))
     ((eqv? type &char) (integer->char val))
     ((eqv? type &unspecified) *unspecified*)
     ((eqv? type &boolean) (not (zero? val)))
     ((eqv? type &nil) #nil)
     ((eqv? type &null) '())
     (else (error "unhandled type" type val))))
  (let* ((typev (infer-types fun dfg #:max-label-count 3000))
         (folded? (and typev
                       (make-bitvector (/ (vector-length typev) 2) #f)))
         (folded-values (and typev
                             (make-vector (bitvector-length folded?) #f))))
    (define (label->idx label) (- label min-label))
    (define (var->idx var) (- var min-var))
    (define (maybe-fold-value! label name k def)
      (call-with-values (lambda () (lookup-post-type typev label def))
        (lambda (type min max)
          (when (and (not (zero? type))
                     (zero? (logand type (1- type)))
                     (zero? (logand type (lognot &scalar-types)))
                     (eqv? min max))
            (bitvector-set! folded? label #t)
            (vector-set! folded-values label (scalar-value type min))))))
    (define (maybe-fold-unary-branch! label name arg)
      (let* ((folder (hashq-ref *branch-folders* name)))
        (when folder
          (call-with-values (lambda () (lookup-pre-type typev label arg))
            (lambda (type min max)
              (call-with-values (lambda () (folder type min max))
                (lambda (f? v)
                  (bitvector-set! folded? label f?)
                  (vector-set! folded-values label v))))))))
    (define (maybe-fold-binary-branch! label name arg0 arg1)
      (let* ((folder (hashq-ref *branch-folders* name)))
        (when folder
          (call-with-values (lambda () (lookup-pre-type typev label arg0))
            (lambda (type0 min0 max0)
              (call-with-values (lambda () (lookup-pre-type typev label arg1))
                (lambda (type1 min1 max1)
                  (call-with-values (lambda ()
                                      (folder type0 min0 max0 type1 min1 max1))
                    (lambda (f? v)
                      (bitvector-set! folded? label f?)
                      (vector-set! folded-values label v))))))))))
    (define (visit-cont cont)
      (match cont
        (($ $cont label ($ $kargs _ _ body))
         (visit-term body label))
        (($ $cont label ($ $kclause arity body alternate))
         (visit-cont body)
         (visit-cont alternate))
        (_ #f)))
    (define (visit-term term label)
      (match term
        (($ $letk conts body)
         (for-each visit-cont conts)
         (visit-term body label))
        (($ $letrec _ _ _ body)
         (visit-term body label))
        (($ $continue k src ($ $primcall name args))
         ;; We might be able to fold primcalls that define a value.
         (match (lookup-cont k dfg)
           (($ $kargs (_) (def))
            (maybe-fold-value! (label->idx label) name (label->idx k)
                               (var->idx def)))
           (_ #f)))
        (($ $continue kf src ($ $branch kt ($ $primcall name args)))
         ;; We might be able to fold primcalls that branch.
         (match args
           ((arg)
            (maybe-fold-unary-branch! (label->idx label) name
                                      (var->idx arg)))
           ((arg0 arg1)
            (maybe-fold-binary-branch! (label->idx label) name
                                       (var->idx arg0) (var->idx arg1)))))
        (_ #f)))
    (when typev
      (match fun
        (($ $cont kfun ($ $kfun src meta self tail clause))
         (visit-cont clause))))
    (values folded? folded-values)))

(define (fold-constants* fun dfg)
  (match fun
    (($ $cont min-label ($ $kfun _ _ min-var))
     (call-with-values (lambda () (compute-folded fun dfg min-label min-var))
       (lambda (folded? folded-values)
         (define (label->idx label) (- label min-label))
         (define (var->idx var) (- var min-var))
         (define (visit-cont cont)
           (rewrite-cps-cont cont
             (($ $cont label ($ $kargs names syms body))
              (label ($kargs names syms ,(visit-term body label))))
             (($ $cont label ($ $kclause arity body alternate))
              (label ($kclause ,arity ,(visit-cont body)
                               ,(and alternate (visit-cont alternate)))))
             (_ ,cont)))
         (define (visit-term term label)
           (rewrite-cps-term term
             (($ $letk conts body)
              ($letk ,(map visit-cont conts)
                ,(visit-term body label)))
             (($ $letrec names vars funs body)
              ($letrec names vars (map visit-fun funs)
                ,(visit-term body label)))
             (($ $continue k src (and fun ($ $fun)))
              ($continue k src ,(visit-fun fun)))
             (($ $continue k src (and primcall ($ $primcall)))
              ,(if (and folded?
                        (bitvector-ref folded? (label->idx label)))
                   (let ((val (vector-ref folded-values (label->idx label))))
                     ;; Uncomment for debugging.
                     ;; (pk 'folded src primcall val)
                     (let-fresh (k*) (v*)
                       ;; Rely on DCE to elide this expression, if
                       ;; possible.
                       (build-cps-term
                         ($letk ((k* ($kargs (#f) (v*)
                                       ($continue k src ($const val)))))
                           ($continue k* src ,primcall)))))
                   term))
             (($ $continue kf src ($ $branch kt ($ $primcall)))
              ,(if (and folded?
                        (bitvector-ref folded? (label->idx label)))
                   ;; Folded branch.
                   (let ((val (vector-ref folded-values (label->idx label))))
                     (build-cps-term
                       ($continue (if val kt kf) src ($values ()))))
                   term))
             (_ ,term)))
         (define (visit-fun fun)
           (rewrite-cps-exp fun
             (($ $fun free body)
              ($fun free ,(fold-constants* body dfg)))))
         (rewrite-cps-cont fun
           (($ $cont kfun ($ $kfun src meta self tail clause))
            (kfun ($kfun src meta self ,tail ,(visit-cont clause))))))))))

(define (type-fold fun)
  (let* ((fun (renumber fun))
         (dfg (compute-dfg fun)))
    (with-fresh-name-state-from-dfg dfg
      (fold-constants* fun dfg))))
Commit	Line	Data
8bc65d2d AW	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 (compute-folded fun dfg min-label min-var)
127	(define (scalar-value type val)
128	(cond
129	((eqv? type &exact-integer) val)
130	((eqv? type &flonum) (exact->inexact val))
131	((eqv? type &char) (integer->char val))
132	((eqv? type &unspecified) unspecified)
133	((eqv? type &boolean) (not (zero? val)))
134	((eqv? type &nil) #nil)
135	((eqv? type &null) '())
136	(else (error "unhandled type" type val))))
a7ee377d AW	137	(let* ((typev (infer-types fun dfg #:max-label-count 3000))
	138	(folded? (and typev
	139	(make-bitvector (/ (vector-length typev) 2) #f)))
	140	(folded-values (and typev
	141	(make-vector (bitvector-length folded?) #f))))
8bc65d2d AW	142	(define (label->idx label) (- label min-label))
	143	(define (var->idx var) (- var min-var))
	144	(define (maybe-fold-value! label name k def)
	145	(call-with-values (lambda () (lookup-post-type typev label def))
	146	(lambda (type min max)
	147	(when (and (not (zero? type))
	148	(zero? (logand type (1- type)))
	149	(zero? (logand type (lognot &scalar-types)))
	150	(eqv? min max))
	151	(bitvector-set! folded? label #t)
	152	(vector-set! folded-values label (scalar-value type min))))))
	153	(define (maybe-fold-unary-branch! label name arg)
	154	(let* ((folder (hashq-ref branch-folders name)))
	155	(when folder
	156	(call-with-values (lambda () (lookup-pre-type typev label arg))
	157	(lambda (type min max)
	158	(call-with-values (lambda () (folder type min max))
	159	(lambda (f? v)
	160	(bitvector-set! folded? label f?)
	161	(vector-set! folded-values label v))))))))
	162	(define (maybe-fold-binary-branch! label name arg0 arg1)
	163	(let* ((folder (hashq-ref branch-folders name)))
	164	(when folder
	165	(call-with-values (lambda () (lookup-pre-type typev label arg0))
	166	(lambda (type0 min0 max0)
	167	(call-with-values (lambda () (lookup-pre-type typev label arg1))
	168	(lambda (type1 min1 max1)
	169	(call-with-values (lambda ()
	170	(folder type0 min0 max0 type1 min1 max1))
	171	(lambda (f? v)
	172	(bitvector-set! folded? label f?)
	173	(vector-set! folded-values label v))))))))))
	174	(define (visit-cont cont)
	175	(match cont
	176	(($ $cont label ($ $kargs _ _ body))
	177	(visit-term body label))
	178	(($ $cont label ($ $kclause arity body alternate))
	179	(visit-cont body)
	180	(visit-cont alternate))
	181	(_ #f)))
	182	(define (visit-term term label)
	183	(match term
	184	(($ $letk conts body)
	185	(for-each visit-cont conts)
	186	(visit-term body label))
	187	(($ $letrec _ _ _ body)
	188	(visit-term body label))
	189	(($ $continue k src ($ $primcall name args))
59258f7c	190	;; We might be able to fold primcalls that define a value.
8bc65d2d AW	191	(match (lookup-cont k dfg)
	192	(($ $kargs (_) (def))
	193	(maybe-fold-value! (label->idx label) name (label->idx k)
	194	(var->idx def)))
8bc65d2d	195	(_ #f)))
92805e21 AW	196	(($ $continue kf src ($ $branch kt ($ $primcall name args)))
	197	;; We might be able to fold primcalls that branch.
	198	(match args
	199	((arg)
	200	(maybe-fold-unary-branch! (label->idx label) name
	201	(var->idx arg)))
	202	((arg0 arg1)
	203	(maybe-fold-binary-branch! (label->idx label) name
	204	(var->idx arg0) (var->idx arg1)))))
8bc65d2d	205	(_ #f)))
a7ee377d AW	206	(when typev
	207	(match fun
	208	(($ $cont kfun ($ $kfun src meta self tail clause))
	209	(visit-cont clause))))
8bc65d2d AW	210	(values folded? folded-values)))
	211
	212	(define (fold-constants* fun dfg)
	213	(match fun
	214	(($ $cont min-label ($ $kfun _ _ min-var))
	215	(call-with-values (lambda () (compute-folded fun dfg min-label min-var))
	216	(lambda (folded? folded-values)
	217	(define (label->idx label) (- label min-label))
	218	(define (var->idx var) (- var min-var))
	219	(define (visit-cont cont)
	220	(rewrite-cps-cont cont
	221	(($ $cont label ($ $kargs names syms body))
	222	(label ($kargs names syms ,(visit-term body label))))
	223	(($ $cont label ($ $kclause arity body alternate))
	224	(label ($kclause ,arity ,(visit-cont body)
	225	,(and alternate (visit-cont alternate)))))
	226	(_ ,cont)))
	227	(define (visit-term term label)
	228	(rewrite-cps-term term
	229	(($ $letk conts body)
	230	($letk ,(map visit-cont conts)
	231	,(visit-term body label)))
	232	(($ $letrec names vars funs body)
	233	($letrec names vars (map visit-fun funs)
	234	,(visit-term body label)))
	235	(($ $continue k src (and fun ($ $fun)))
	236	($continue k src ,(visit-fun fun)))
	237	(($ $continue k src (and primcall ($ $primcall)))
a7ee377d AW	238	,(if (and folded?
a7ee377d AW	239	(bitvector-ref folded? (label->idx label)))
8bc65d2d AW	240	(let ((val (vector-ref folded-values (label->idx label))))
	241	;; Uncomment for debugging.
	242	;; (pk 'folded src primcall val)
59258f7c AW	243	(let-fresh (k) (v)
	244	;; Rely on DCE to elide this expression, if
	245	;; possible.
	246	(build-cps-term
	247	($letk ((k* ($kargs (#f) (v*)
	248	($continue k src ($const val)))))
	249	($continue k* src ,primcall)))))
8bc65d2d	250	term))
92805e21 AW	251	(($ $continue kf src ($ $branch kt ($ $primcall)))
	252	,(if (and folded?
	253	(bitvector-ref folded? (label->idx label)))
	254	;; Folded branch.
	255	(let ((val (vector-ref folded-values (label->idx label))))
	256	(build-cps-term
	257	($continue (if val kt kf) src ($values ()))))
	258	term))
8bc65d2d AW	259	(_ ,term)))
	260	(define (visit-fun fun)
	261	(rewrite-cps-exp fun
	262	(($ $fun free body)
	263	($fun free ,(fold-constants* body dfg)))))
	264	(rewrite-cps-cont fun
	265	(($ $cont kfun ($ $kfun src meta self tail clause))
	266	(kfun ($kfun src meta self ,tail ,(visit-cont clause))))))))))
	267
	268	(define (type-fold fun)
	269	(let* ((fun (renumber fun))
	270	(dfg (compute-dfg fun)))
	271	(with-fresh-name-state-from-dfg dfg
	272	(fold-constants* fun dfg))))