wingo pushed a commit to branch wip-optimize-return-values-checks in repository guile.
commit b9984e4cbd2091273d0d7ffe84abf7e887d72c25 Author: Andy Wingo <[email protected]> AuthorDate: Mon Nov 15 10:39:04 2021 +0100 Allow callk to continue to kargs * module/language/cps/verify.scm (check-arities): If a callk continues to kargs, the caller knows the number of return values that the callee provides and no number-of-values check is needed. * module/language/cps/contification.scm (apply-contification): Allow contification of known-return-values calls. * module/language/cps/reify-primitives.scm (uniquify-receive) (reify-primitives): No need for uniquify-receive any more as receive shuffles are attached to the call, not the continuation. --- module/language/cps/contification.scm | 9 +++++++-- module/language/cps/reify-primitives.scm | 20 -------------------- module/language/cps/verify.scm | 14 +++++++------- 3 files changed, 14 insertions(+), 29 deletions(-) diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm index 8f07f79..7a05fa2 100644 --- a/module/language/cps/contification.scm +++ b/module/language/cps/contification.scm @@ -469,8 +469,9 @@ function set." (if (eq? k k*) (with-cps cps (build-term ($continue k src ,exp))) ;; We are contifying this return. It must be a call or a - ;; $values expression. k* will be either a $ktail or a - ;; $kreceive continuation. + ;; $values expression. k* will be a $ktail or a $kreceive + ;; continuation, or a $kargs continuation for a + ;; known-number-of-values return. (match (intmap-ref conts k*) (($ $kreceive ($ $arity req () rest () #f) kargs) (match exp @@ -480,6 +481,10 @@ function set." ;; have to rewrite as a call to the 'values primitive. (($ $values vals) (inline-return cps k* kargs src (length req) rest vals)))) + (($ $kargs) + (match exp + ((or ($ $callk) ($ $values)) + (with-cps cps (build-term ($continue k* src ,exp)))))) (($ $ktail) (with-cps cps (build-term ($continue k* src ,exp)))))))) (define (contify-unchecked-function cps kfun) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index d0441ff..5f42415 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -102,16 +102,6 @@ (letk kclause ($kclause ('() '() #f '() #f) kbody #f)) kclause)) -;; A $kreceive continuation should have only one predecessor. -(define (uniquify-receive cps k) - (match (intmap-ref cps k) - (($ $kreceive ($ $arity req () rest () #f) kargs) - (with-cps cps - (letk k ($kreceive req rest kargs)) - k)) - (_ - (with-cps cps k)))) - (define (wrap-unary cps k src wrap unwrap op param a) (with-cps cps (letv a* res*) @@ -619,16 +609,6 @@ ((imm-s64-< (s12? a) b) load-s64 (s64-< a b)) ((eq-constant? (imm16? b) a) load-const (eq? a b)) (_ cps)))) - (($ $kargs names vars ($ $continue k src ($ $call proc args))) - (with-cps cps - (let$ k (uniquify-receive k)) - (setk label ($kargs names vars - ($continue k src ($call proc args)))))) - (($ $kargs names vars ($ $continue k src ($ $callk k* proc args))) - (with-cps cps - (let$ k (uniquify-receive k)) - (setk label ($kargs names vars - ($continue k src ($callk k* proc args)))))) (_ cps))) (with-fresh-name-state cps diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index 88dcbc0..58317ae 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -1,5 +1,5 @@ ;;; Diagnostic checker for CPS -;;; Copyright (C) 2014-2020 Free Software Foundation, Inc. +;;; Copyright (C) 2014-2021 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 @@ -271,10 +271,6 @@ definitions that are available at LABEL." (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) ($ $const-fun) ($ $code) ($ $fun)) (assert-unary)) @@ -291,9 +287,13 @@ definitions that are available at LABEL." (($ $ktail) #t) (_ (assert-n-ary (length args))))) (($ $call proc args) - (assert-kreceive-or-ktail)) + (match cont + ((or ($ $kreceive) ($ $ktail)) #t) + (_ (error "expected $kreceive or $ktail continuation" cont)))) (($ $callk k proc args) - (assert-kreceive-or-ktail)) + (match cont + ((or ($ $kargs) ($ $kreceive) ($ $ktail)) #t) + (_ (error "expected $kargs, $kreceive or $ktail continuation" cont)))) (($ $primcall name param args) (match cont (($ $kargs) #t)
