From 86e86ec1c7033ca723de527cca6c167a7577258f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 21 Apr 2021 22:08:00 +0200 Subject: [PATCH] New pass: elide-arity-checks * module/language/cps/elide-arity-checks.scm: New file. Elides argument count checks for known callers. * am/bootstrap.am (SOURCES): * module/Makefile.am (SOURCES): Add new file. * module/language/cps/optimize.scm (optimize-first-order-cps): * module/system/base/optimize.scm (available-optimizations): Add new pass. --- am/bootstrap.am | 1 + module/Makefile.am | 1 + module/language/cps/elide-arity-checks.scm | 107 +++++++++++++++++++++ module/language/cps/optimize.scm | 4 +- module/system/base/optimize.scm | 1 + 5 files changed, 113 insertions(+), 1 deletion(-) create mode 100644 module/language/cps/elide-arity-checks.scm diff --git a/am/bootstrap.am b/am/bootstrap.am index acc00c762..1ba52dd37 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -133,6 +133,7 @@ SOURCES = \ language/cps/dce.scm \ language/cps/devirtualize-integers.scm \ language/cps/effects-analysis.scm \ + language/cps/elide-arity-checks.scm \ language/cps/intmap.scm \ language/cps/intset.scm \ language/cps/graphs.scm \ diff --git a/module/Makefile.am b/module/Makefile.am index b836812ac..85c03d6f1 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -52,6 +52,7 @@ SOURCES = \ language/cps/cse.scm \ language/cps/dce.scm \ language/cps/devirtualize-integers.scm \ + language/cps/elide-arity-checks.scm \ language/cps/effects-analysis.scm \ language/cps/graphs.scm \ language/cps/intmap.scm \ diff --git a/module/language/cps/elide-arity-checks.scm b/module/language/cps/elide-arity-checks.scm new file mode 100644 index 000000000..48883bd6e --- /dev/null +++ b/module/language/cps/elide-arity-checks.scm @@ -0,0 +1,107 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 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 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: +;;; +;;; If we have a $callk to a $kfun that has a $kclause, in most cases we +;;; can skip arity checks because the caller knows what arity the callee +;;; is expecting. +;;; +;;; Code: + +(define-module (language cps elide-arity-checks) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps intmap) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:export (elide-arity-checks)) + +(define (arity-matches? arity self proc args) + (match arity + (($ $arity req () #f () #f) + (= (+ (length req) (if self 1 0)) + (+ (length args) (if proc 1 0)))) + (_ #f))) + +(define (maybe-elide-arity-check cps kfun proc args) + (match (intmap-ref cps kfun) + (($ $kfun fsrc meta self ktail kentry) + (match (and kentry (intmap-ref cps kentry)) + (($ $kclause (? (lambda (arity) + (arity-matches? arity self proc args)) + arity) + kbody #f) + ;; This is a compatible $callk to a $kfun that checks its arity + ;; and has no alternate; arrange to elide the check. + (match (intmap-ref cps kbody) + (($ $kargs fnames fvars term) + (match term + (($ $continue (? (lambda (k) (eq? k ktail))) _ + ($ $callk kfun' + (? (lambda (proc') (eq? proc' self))) + (? (lambda (args) (equal? args fvars))))) + ;; This function already trampolines out to another + ;; function; forward this call there. Could recurse but + ;; we shouldn't need to, and we don't so as to avoid + ;; divergence. + (with-cps cps + (build-exp + ($callk kfun' proc args)))) + (_ + ;; Define a new unchecked function containing the body of + ;; this function. + (let ((self' (and self (fresh-var))) + (fvars' (map (lambda (_) (fresh-var)) fvars))) + (with-cps cps + ;; Entry of new kfun' is the $kargs kbody. + (letk kfun' ($kfun fsrc meta self ktail kbody)) + (letk ktail' ($ktail)) + (letk kbody' ($kargs fnames fvars' + ($continue ktail' fsrc + ($callk kfun' self' fvars')))) + (letk kentry' ($kclause ,arity kbody' #f)) + (setk kfun ($kfun fsrc meta self' ktail' kentry')) + ;; Dispatch source $callk to new kfun'. + (build-exp + ($callk kfun' proc args))))))))) + (_ + ;; Either this is already a $callk to a "raw" $kfun (one that + ;; doesn't check its arity), in which case we're good; or a call + ;; with possibly incompatible arity, or a call to a case-lambda, + ;; in which case we punt for now. + (with-cps cps + (build-exp ($callk kfun proc args)))))))) + +;; This transformation removes references to arity-checking $kfun's, but +;; doesn't remove them, leaving that to renumbering or DCE to fix up. +(define (elide-arity-checks cps) + (with-fresh-name-state cps + (persistent-intmap + (intmap-fold + (lambda (label cont cps) + (match cont + (($ $kargs names vars + ($ $continue k src ($ $callk kfun proc args))) + (with-cps cps + (let$ exp (maybe-elide-arity-check kfun proc args)) + (setk label ($kargs names vars + ($continue k src ,exp))))) + (_ cps))) + (persistent-intmap cps) + (transient-intmap cps))))) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index 3829be6ce..147522410 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2018,2020 Free Software Foundation, Inc. +;; Copyright (C) 2013-2018,2020,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 published by @@ -28,6 +28,7 @@ #:use-module (language cps cse) #:use-module (language cps dce) #:use-module (language cps devirtualize-integers) + #:use-module (language cps elide-arity-checks) #:use-module (language cps licm) #:use-module (language cps loop-instrumentation) #:use-module (language cps peel-loops) @@ -103,6 +104,7 @@ (simplify #:simplify?)) (define-optimizer optimize-first-order-cps + (elide-arity-checks #:elide-arity-checks?) (specialize-numbers #:specialize-numbers?) (hoist-loop-invariant-code #:licm?) (specialize-primcalls #:specialize-primcalls?) diff --git a/module/system/base/optimize.scm b/module/system/base/optimize.scm index cf40cb8a2..03c57bf1b 100644 --- a/module/system/base/optimize.scm +++ b/module/system/base/optimize.scm @@ -44,6 +44,7 @@ (#:peel-loops? 2) (#:cse? 2) (#:type-fold? 2) + (#:elide-arity-checks? 2) (#:resolve-self-references? 2) (#:devirtualize-integers? 2) (#:specialize-numbers? 2)