mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Type and range inference for CPS

Browse source 
* module/language/cps/types.scm: New file, implementing type and range
  inference over CPS.

* module/language/cps/type-fold.scm: New file, implementing abstract
  constant folding for CPS.

* module/Makefile.am: Add the new files.

* module/language/cps/compile-bytecode.scm: Wire up type-fold, but
  currently disabled.
This commit is contained in:
Andy Wingo 2014-05-13 16:14:35 +02:00
parent 7ed92f0a9c
commit 8bc65d2d64
4 changed files with 1706 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

2
module/Makefile.am
View file

@ -138,6 +138,8 @@ CPS_LANG_SOURCES = \
language/cps/simplify.scm \
language/cps/spec.scm \
language/cps/specialize-primcalls.scm \
language/cps/types.scm \
language/cps/type-fold.scm \
language/cps/verify.scm
BYTECODE_LANG_SOURCES = \

2
module/language/cps/compile-bytecode.scm
View file

@ -44,6 +44,7 @@
#:use-module (language cps simplify)
#:use-module (language cps slot-allocation)
#:use-module (language cps specialize-primcalls)
#:use-module (language cps type-fold)
#:use-module (system vm assembler)
#:export (compile-bytecode))
@ -73,6 +74,7 @@
(exp (run-pass exp elide-values #:elide-values? #t))
(exp (run-pass exp prune-bailouts #:prune-bailouts? #t))
(exp (run-pass exp eliminate-common-subexpressions #:cse? #t))
(exp (run-pass exp type-fold #:type-fold? #f))
(exp (run-pass exp resolve-self-references #:resolve-self-references? #t))
(exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
(exp (run-pass exp simplify #:simplify? #t)))

266
module/language/cps/type-fold.scm Normal file
View file

@ -0,0 +1,266 @@
;;; 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))
(folded? (make-bitvector (/ (vector-length typev) 2) #f))
(folded-values (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 or
;; that branch.
(match (lookup-cont k dfg)
(($ $kargs (_) (def))
(maybe-fold-value! (label->idx label) name (label->idx k)
(var->idx def)))
(($ $kif kt kf)
(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)))
(_ #f)))
(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 (bitvector-ref folded? (label->idx label))
(let ((val (vector-ref folded-values (label->idx label))))
;; Uncomment for debugging.
;; (pk 'folded src primcall val)
(match (lookup-cont k dfg)
(($ $kargs)
(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)))))
(($ $kif kt kf)
;; Folded branch.
(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))))

1436
module/language/cps/types.scm Normal file
View file

File diff suppressed because it is too large Load diff