mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-17 20:32:24 +02:00
c54c151eb6
* module/language/cps.scm ($primcall): Add "param" member, which will be a constant parameter to the primcall. The idea is that constants used by primcalls as immediates don't need to participate in optimizations in any way -- they should not participate in CSE, have the same lifetime as the primcall so not part of DCE either, and don't need slot allocation. Indirecting them through a named $const binding is complication for no benefit. This change should eventually improve compilation time and memory usage, once we fully take advantage of it, as the number of labels and variables will go down. * module/language/cps/closure-conversion.scm: * module/language/cps/compile-bytecode.scm: * module/language/cps/constructors.scm: * module/language/cps/contification.scm: * module/language/cps/cse.scm: * module/language/cps/dce.scm: * module/language/cps/effects-analysis.scm: * module/language/cps/elide-values.scm: * module/language/cps/handle-interrupts.scm: * module/language/cps/licm.scm: * module/language/cps/peel-loops.scm: * module/language/cps/prune-bailouts.scm: * module/language/cps/prune-top-level-scopes.scm: * module/language/cps/reify-primitives.scm: * module/language/cps/renumber.scm: * module/language/cps/rotate-loops.scm: * module/language/cps/self-references.scm: * module/language/cps/simplify.scm: * module/language/cps/slot-allocation.scm: * module/language/cps/specialize-numbers.scm: * module/language/cps/specialize-primcalls.scm: * module/language/cps/split-rec.scm: * module/language/cps/type-checks.scm: * module/language/cps/type-fold.scm: * module/language/cps/types.scm: * module/language/cps/utils.scm: * module/language/cps/verify.scm: * module/language/tree-il/compile-cps.scm: Adapt all users.
301 lines
10 KiB
Scheme
301 lines
10 KiB
Scheme
;;; Diagnostic checker for CPS
|
|
;;; Copyright (C) 2014, 2015, 2017 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:
|
|
;;;
|
|
;;; A routine to detect invalid CPS.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define-module (language cps verify)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (language cps)
|
|
#:use-module (language cps utils)
|
|
#:use-module (language cps intmap)
|
|
#:use-module (language cps intset)
|
|
#:use-module (language cps primitives)
|
|
#:use-module (srfi srfi-11)
|
|
#:export (verify))
|
|
|
|
(define (intset-pop set)
|
|
(match (intset-next set)
|
|
(#f (values set #f))
|
|
(i (values (intset-remove set i) i))))
|
|
|
|
(define-syntax-rule (make-worklist-folder* seed ...)
|
|
(lambda (f worklist seed ...)
|
|
(let lp ((worklist worklist) (seed seed) ...)
|
|
(call-with-values (lambda () (intset-pop worklist))
|
|
(lambda (worklist i)
|
|
(if i
|
|
(call-with-values (lambda () (f i seed ...))
|
|
(lambda (i* seed ...)
|
|
(let add ((i* i*) (worklist worklist))
|
|
(match i*
|
|
(() (lp worklist seed ...))
|
|
((i . i*) (add i* (intset-add worklist i)))))))
|
|
(values seed ...)))))))
|
|
|
|
(define worklist-fold*
|
|
(case-lambda
|
|
((f worklist seed)
|
|
((make-worklist-folder* seed) f worklist seed))))
|
|
|
|
(define (check-distinct-vars conts)
|
|
(define (adjoin-def var seen)
|
|
(when (intset-ref seen var)
|
|
(error "duplicate var name" seen var))
|
|
(intset-add seen var))
|
|
(intmap-fold
|
|
(lambda (label cont seen)
|
|
(match (intmap-ref conts label)
|
|
(($ $kargs names vars ($ $continue k src exp))
|
|
(fold1 adjoin-def vars seen))
|
|
(($ $kfun src meta self tail clause)
|
|
(adjoin-def self seen))
|
|
(_ seen))
|
|
)
|
|
conts
|
|
empty-intset))
|
|
|
|
(define (compute-available-definitions conts kfun)
|
|
"Compute and return a map of LABEL->VAR..., where VAR... are the
|
|
definitions that are available at LABEL."
|
|
(define (adjoin-def var defs)
|
|
(when (intset-ref defs var)
|
|
(error "var already present in defs" defs var))
|
|
(intset-add defs var))
|
|
|
|
(define (propagate defs succ out)
|
|
(let* ((in (intmap-ref defs succ (lambda (_) #f)))
|
|
(in* (if in (intset-intersect in out) out)))
|
|
(if (eq? in in*)
|
|
(values '() defs)
|
|
(values (list succ)
|
|
(intmap-add defs succ in* (lambda (old new) new))))))
|
|
|
|
(define (visit-cont label defs)
|
|
(let ((in (intmap-ref defs label)))
|
|
(define (propagate0 out)
|
|
(values '() defs))
|
|
(define (propagate1 succ out)
|
|
(propagate defs succ out))
|
|
(define (propagate2 succ0 succ1 out)
|
|
(let*-values (((changed0 defs) (propagate defs succ0 out))
|
|
((changed1 defs) (propagate defs succ1 out)))
|
|
(values (append changed0 changed1) defs)))
|
|
|
|
(match (intmap-ref conts label)
|
|
(($ $kargs names vars ($ $continue k src exp))
|
|
(let ((out (fold1 adjoin-def vars in)))
|
|
(match exp
|
|
(($ $branch kt) (propagate2 k kt out))
|
|
(($ $prompt escape? tag handler) (propagate2 k handler out))
|
|
(_ (propagate1 k out)))))
|
|
(($ $kreceive arity k)
|
|
(propagate1 k in))
|
|
(($ $kfun src meta self tail clause)
|
|
(let ((out (adjoin-def self in)))
|
|
(if clause
|
|
(propagate1 clause out)
|
|
(propagate0 out))))
|
|
(($ $kclause arity kbody kalt)
|
|
(if kalt
|
|
(propagate2 kbody kalt in)
|
|
(propagate1 kbody in)))
|
|
(($ $ktail) (propagate0 in)))))
|
|
|
|
(worklist-fold* visit-cont
|
|
(intset kfun)
|
|
(intmap-add empty-intmap kfun empty-intset)))
|
|
|
|
(define (intmap-for-each f map)
|
|
(intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
|
|
|
|
(define (check-valid-var-uses conts kfun)
|
|
(define (adjoin-def var defs) (intset-add defs var))
|
|
(let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset))
|
|
(define (visit-exp exp bound first-order)
|
|
(define (check-use var)
|
|
(unless (intset-ref bound var)
|
|
(error "unbound var" var)))
|
|
(define (visit-first-order kfun)
|
|
(if (intset-ref first-order kfun)
|
|
first-order
|
|
(visit-fun kfun empty-intset (intset-add first-order kfun))))
|
|
(match exp
|
|
((or ($ $const) ($ $prim)) first-order)
|
|
;; todo: $closure
|
|
(($ $fun kfun)
|
|
(visit-fun kfun bound first-order))
|
|
(($ $closure kfun)
|
|
(visit-first-order kfun))
|
|
(($ $rec names vars (($ $fun kfuns) ...))
|
|
(let ((bound (fold1 adjoin-def vars bound)))
|
|
(fold1 (lambda (kfun first-order)
|
|
(visit-fun kfun bound first-order))
|
|
kfuns first-order)))
|
|
(($ $values args)
|
|
(for-each check-use args)
|
|
first-order)
|
|
(($ $call proc args)
|
|
(check-use proc)
|
|
(for-each check-use args)
|
|
first-order)
|
|
(($ $callk kfun proc args)
|
|
(check-use proc)
|
|
(for-each check-use args)
|
|
(visit-first-order kfun))
|
|
(($ $branch kt ($ $primcall name param args))
|
|
(for-each check-use args)
|
|
first-order)
|
|
(($ $primcall name param args)
|
|
(for-each check-use args)
|
|
first-order)
|
|
(($ $prompt escape? tag handler)
|
|
(check-use tag)
|
|
first-order)))
|
|
(intmap-fold
|
|
(lambda (label bound first-order)
|
|
(let ((bound (intset-union free bound)))
|
|
(match (intmap-ref conts label)
|
|
(($ $kargs names vars ($ $continue k src exp))
|
|
(visit-exp exp (fold1 adjoin-def vars bound) first-order))
|
|
(_ first-order))))
|
|
(compute-available-definitions conts kfun)
|
|
first-order)))
|
|
|
|
(define (check-label-partition conts kfun)
|
|
;; A continuation can only belong to one function.
|
|
(intmap-fold
|
|
(lambda (kfun body seen)
|
|
(intset-fold
|
|
(lambda (label seen)
|
|
(intmap-add seen label kfun
|
|
(lambda (old new)
|
|
(error "label used by two functions" label old new))))
|
|
body
|
|
seen))
|
|
(compute-reachable-functions conts kfun)
|
|
empty-intmap))
|
|
|
|
(define (compute-reachable-labels conts kfun)
|
|
(intmap-fold (lambda (kfun body seen) (intset-union seen body))
|
|
(compute-reachable-functions conts kfun)
|
|
empty-intset))
|
|
|
|
(define (check-arities conts kfun)
|
|
(define (check-arity exp cont)
|
|
(define (assert-unary)
|
|
(match cont
|
|
(($ $kargs (_) (_)) #t)
|
|
(_ (error "expected unary continuation" cont))))
|
|
(define (assert-nullary)
|
|
(match cont
|
|
(($ $kargs () ()) #t)
|
|
(_ (error "expected unary continuation" cont))))
|
|
(define (assert-n-ary n)
|
|
(match cont
|
|
(($ $kargs names vars)
|
|
(unless (= (length vars) n)
|
|
(error "expected n-ary continuation" n cont)))
|
|
(_ (error "expected $kargs continuation" cont))))
|
|
(define (assert-kreceive-or-ktail)
|
|
(match cont
|
|
((or ($ $kreceive) ($ $ktail)) #t)
|
|
(_ (error "expected $kreceive or $ktail continuation" cont))))
|
|
(match exp
|
|
((or ($ $const) ($ $prim) ($ $closure) ($ $fun))
|
|
(assert-unary))
|
|
(($ $rec names vars funs)
|
|
(unless (= (length names) (length vars) (length funs))
|
|
(error "invalid $rec" exp))
|
|
(assert-n-ary (length names))
|
|
(match cont
|
|
(($ $kargs names vars*)
|
|
(unless (equal? vars* vars)
|
|
(error "bound variable mismatch" vars vars*)))))
|
|
(($ $values args)
|
|
(match cont
|
|
(($ $ktail) #t)
|
|
(_ (assert-n-ary (length args)))))
|
|
(($ $call proc args)
|
|
(assert-kreceive-or-ktail))
|
|
(($ $callk k proc args)
|
|
(assert-kreceive-or-ktail))
|
|
(($ $branch kt exp)
|
|
(assert-nullary)
|
|
(match (intmap-ref conts kt)
|
|
(($ $kargs () ()) #t)
|
|
(cont (error "bad kt" cont))))
|
|
(($ $primcall name param args)
|
|
(match cont
|
|
(($ $kargs names)
|
|
(match (prim-arity name)
|
|
((out . in)
|
|
(unless (= in (length args))
|
|
(error "bad arity to primcall" name args in))
|
|
(unless (= out (length names))
|
|
(error "bad return arity from primcall" name names out)))))
|
|
(($ $kreceive)
|
|
(when (false-if-exception (prim-arity name))
|
|
(error "primitive should continue to $kargs, not $kreceive" name)))
|
|
(($ $ktail)
|
|
(error "primitive should continue to $kargs, not $ktail" name))))
|
|
(($ $prompt escape? tag handler)
|
|
(assert-nullary)
|
|
(match (intmap-ref conts handler)
|
|
(($ $kreceive) #t)
|
|
(cont (error "bad handler" cont))))))
|
|
(let ((reachable (compute-reachable-labels conts kfun)))
|
|
(intmap-for-each
|
|
(lambda (label cont)
|
|
(when (intset-ref reachable label)
|
|
(match cont
|
|
(($ $kargs names vars ($ $continue k src exp))
|
|
(unless (= (length names) (length vars))
|
|
(error "broken $kargs" label names vars))
|
|
(check-arity exp (intmap-ref conts k)))
|
|
(_ #t))))
|
|
conts)))
|
|
|
|
(define (check-functions-bound-once conts kfun)
|
|
(let ((reachable (compute-reachable-labels conts kfun)))
|
|
(define (add-fun fun functions)
|
|
(when (intset-ref functions fun)
|
|
(error "function already bound" fun))
|
|
(intset-add functions fun))
|
|
(intmap-fold
|
|
(lambda (label cont functions)
|
|
(if (intset-ref reachable label)
|
|
(match cont
|
|
(($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
|
|
(add-fun kfun functions))
|
|
(($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...))))
|
|
(fold1 add-fun kfuns functions))
|
|
(_ functions))
|
|
functions))
|
|
conts
|
|
empty-intset)))
|
|
|
|
(define (verify conts)
|
|
(check-distinct-vars conts)
|
|
(check-label-partition conts 0)
|
|
(check-valid-var-uses conts 0)
|
|
(check-arities conts 0)
|
|
(check-functions-bound-once conts 0)
|
|
conts)
|