--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 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 library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; Various optimizations can inline calls from one continuation to some
+;;; other continuation, usually in response to information about the
+;;; return arity of the call. That leaves us with dangling
+;;; continuations that aren't reachable any more from the procedure
+;;; entry. This pass will remove them.
+;;;
+;;; This pass also kills dead expressions: code that has no side
+;;; effects, and whose value is unused. It does so by marking all live
+;;; values, and then discarding other values as dead. This happens
+;;; recursively through procedures, so it should be possible to elide
+;;; dead procedures as well.
+;;;
+;;; Code:
+
+(define-module (language cps dce)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps effects-analysis)
+ #:export (eliminate-dead-code))
+
+(define-record-type $fun-data
+ (make-fun-data cfa effects conts live-conts defs)
+ fun-data?
+ (cfa fun-data-cfa)
+ (effects fun-data-effects)
+ (conts fun-data-conts)
+ (live-conts fun-data-live-conts)
+ (defs fun-data-defs))
+
+(define (compute-cont-vector cfa cont-table)
+ (let ((v (make-vector (cfa-k-count cfa) #f)))
+ (let lp ((n 0))
+ (when (< n (vector-length v))
+ (vector-set! v n (lookup-cont (cfa-k-sym cfa n) cont-table))
+ (lp (1+ n))))
+ v))
+
+(define (compute-defs cfa contv)
+ (define (cont-defs k)
+ (match (vector-ref contv (cfa-k-idx cfa k))
+ (($ $kargs names syms) syms)
+ (_ #f)))
+ (let ((defs (make-vector (vector-length contv) #f)))
+ (let lp ((n 0))
+ (when (< n (vector-length contv))
+ (vector-set!
+ defs
+ n
+ (match (vector-ref contv n)
+ (($ $kargs _ _ body)
+ (match (find-call body)
+ (($ $continue k) (cont-defs k))))
+ (($ $ktrunc arity kargs)
+ (cont-defs kargs))
+ (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
+ syms)
+ (($ $kif) #f)
+ (($ $kentry self) (list self))
+ (($ $ktail) #f)))
+ (lp (1+ n))))
+ defs))
+
+(define (compute-live-code fun)
+ (let ((fun-data-table (make-hash-table))
+ (live-vars (make-hash-table))
+ (dfg (compute-dfg fun #:global? #t))
+ (changed? #f))
+ (define (mark-live! sym)
+ (unless (value-live? sym)
+ (set! changed? #t)
+ (hashq-set! live-vars sym #t)))
+ (define (value-live? sym)
+ (hashq-ref live-vars sym))
+ (define (ensure-fun-data fun)
+ (or (hashq-ref fun-data-table fun)
+ (let* ((cfa (analyze-control-flow fun dfg))
+ (effects (compute-effects cfa dfg))
+ (contv (compute-cont-vector cfa (dfg-cont-table dfg)))
+ (live-conts (make-bitvector (cfa-k-count cfa) #f))
+ (defs (compute-defs cfa contv))
+ (fun-data (make-fun-data cfa effects contv live-conts defs)))
+ (hashq-set! fun-data-table fun fun-data)
+ (set! changed? #t)
+ fun-data)))
+ (define (visit-fun fun)
+ (match (ensure-fun-data fun)
+ (($ $fun-data cfa effects contv live-conts defs)
+ (define (visit-grey-exp n)
+ (let ((defs (vector-ref defs n)))
+ (cond
+ ((not defs) #t)
+ ((not (effect-free? (exclude-effects (vector-ref effects n)
+ &allocation)))
+ #t)
+ (else
+ (or-map value-live? defs)))))
+ (let lp ((n (1- (cfa-k-count cfa))))
+ (unless (< n 0)
+ (let ((cont (vector-ref contv n)))
+ (match cont
+ (($ $kargs _ _ body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names syms funs body)
+ (lp body)
+ (for-each (lambda (sym fun)
+ (when (value-live? sym)
+ (visit-fun fun)))
+ syms funs))
+ (($ $continue k src exp)
+ (unless (bitvector-ref live-conts n)
+ (when (visit-grey-exp n)
+ (set! changed? #t)
+ (bitvector-set! live-conts n #t)))
+ (when (bitvector-ref live-conts n)
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim))
+ #f)
+ ((and fun ($ $fun))
+ (visit-fun fun))
+ (($ $prompt escape? tag handler)
+ (mark-live! tag))
+ (($ $call proc args)
+ (mark-live! proc)
+ (for-each mark-live! args))
+ (($ $primcall name args)
+ (for-each mark-live! args))
+ (($ $values args)
+ (match (vector-ref defs n)
+ (#f (for-each mark-live! args))
+ (defs (for-each (lambda (use def)
+ (when (value-live? def)
+ (mark-live! use)))
+ args defs))))))))))
+ (($ $ktrunc arity kargs) #f)
+ (($ $kif) #f)
+ (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
+ (for-each mark-live! syms))
+ (($ $kentry self tail clauses)
+ (mark-live! self))
+ (($ $ktail) #f))
+ (lp (1- n))))))))
+ (let lp ()
+ (set! changed? #f)
+ (visit-fun fun)
+ (when changed? (lp)))
+ (values fun-data-table live-vars)))
+
+(define (eliminate-dead-code fun)
+ (call-with-values (lambda () (compute-live-code fun))
+ (lambda (fun-data-table live-vars)
+ (define (value-live? sym)
+ (hashq-ref live-vars sym))
+ (define (make-adaptor name k defs)
+ (let* ((names (map (lambda (_) 'tmp) defs))
+ (syms (map (lambda (_) (gensym "tmp")) defs))
+ (live (filter-map (lambda (def sym)
+ (and (value-live? def)
+ sym))
+ defs syms)))
+ (build-cps-cont
+ (name ($kargs names syms
+ ($continue k #f ($values live)))))))
+ (define (visit-fun fun)
+ (match (hashq-ref fun-data-table fun)
+ (($ $fun-data cfa effects contv live-conts defs)
+ (define (must-visit-cont cont)
+ (match (visit-cont cont)
+ ((cont) cont)
+ (conts (error "cont must be reachable" cont conts))))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont sym cont)
+ (match (cfa-k-idx cfa sym #:default (lambda (k) #f))
+ (#f '())
+ (n
+ (match cont
+ (($ $kargs names syms body)
+ (match (filter-map (lambda (name sym)
+ (and (value-live? sym)
+ (cons name sym)))
+ names syms)
+ (((names . syms) ...)
+ (list
+ (build-cps-cont
+ (sym ($kargs names syms
+ ,(visit-term body n))))))))
+ (($ $kentry self tail clauses)
+ (list
+ (build-cps-cont
+ (sym ($kentry self ,tail
+ ,(visit-conts clauses))))))
+ (($ $kclause arity body)
+ (list
+ (build-cps-cont
+ (sym ($kclause ,arity
+ ,(must-visit-cont body))))))
+ (($ $ktrunc ($ $arity req () rest () #f) kargs)
+ (let ((defs (vector-ref defs n)))
+ (if (and-map value-live? defs)
+ (list (build-cps-cont (sym ,cont)))
+ (let-gensyms (adapt)
+ (list (make-adaptor adapt kargs defs)
+ (build-cps-cont
+ (sym ($ktrunc req rest adapt))))))))
+ (_ (list (build-cps-cont (sym ,cont))))))))))
+ (define (visit-conts conts)
+ (append-map visit-cont conts))
+ (define (visit-term term term-k-idx)
+ (match term
+ (($ $letk conts body)
+ (let ((body (visit-term body term-k-idx)))
+ (match (visit-conts conts)
+ (() body)
+ (conts (build-cps-term ($letk ,conts ,body))))))
+ (($ $letrec names syms funs body)
+ (let ((body (visit-term body term-k-idx)))
+ (match (filter-map
+ (lambda (name sym fun)
+ (and (value-live? sym)
+ (list name sym (visit-fun fun))))
+ names syms funs)
+ (() body)
+ (((names syms funs) ...)
+ (build-cps-term
+ ($letrec names syms funs ,body))))))
+ (($ $continue k src ($ $values args))
+ (match (vector-ref defs term-k-idx)
+ (#f term)
+ (defs
+ (let ((args (filter-map (lambda (use def)
+ (and (value-live? def) use))
+ args defs)))
+ (build-cps-term
+ ($continue k src ($values args)))))))
+ (($ $continue k src exp)
+ (if (bitvector-ref live-conts term-k-idx)
+ (rewrite-cps-term exp
+ (($ $fun) ($continue k src ,(visit-fun exp)))
+ (_
+ ,(match (vector-ref defs term-k-idx)
+ ((or #f ((? value-live?) ...))
+ (build-cps-term
+ ($continue k src ,exp)))
+ (syms
+ (let-gensyms (adapt)
+ (build-cps-term
+ ($letk (,(make-adaptor adapt k syms))
+ ($continue adapt src ,exp))))))))
+ (build-cps-term ($continue k src ($values ())))))))
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta free ,(must-visit-cont body)))))))
+ (visit-fun fun))))
HCoop / bpt / guile.git / commitdiff