1;;; Continuation-passing style (CPS) intermediate language (IL) 2 3;; Copyright (C) 2021 Free Software Foundation, Inc. 4 5;;;; This library is free software; you can redistribute it and/or 6;;;; modify it under the terms of the GNU Lesser General Public 7;;;; License as published by the Free Software Foundation; either 8;;;; version 3 of the License, or (at your option) any later version. 9;;;; 10;;;; This library is distributed in the hope that it will be useful, 11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13;;;; Lesser General Public License for more details. 14;;;; 15;;;; You should have received a copy of the GNU Lesser General Public 16;;;; License along with this library; if not, write to the Free Software 17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 19;;; Commentary: 20;;; 21;;; If we have a $callk to a $kfun that has a $kclause, in most cases we 22;;; can skip arity checks because the caller knows what arity the callee 23;;; is expecting. 24;;; 25;;; Code: 26 27(define-module (language cps elide-arity-checks) 28 #:use-module (ice-9 match) 29 #:use-module (language cps) 30 #:use-module (language cps intmap) 31 #:use-module (language cps utils) 32 #:use-module (language cps with-cps) 33 #:export (elide-arity-checks)) 34 35(define (arity-matches? arity self proc args) 36 (match arity 37 (($ $arity req () #f () #f) 38 (= (+ (length req) (if self 1 0)) 39 (+ (length args) (if proc 1 0)))) 40 (_ #f))) 41 42(define (maybe-elide-arity-check cps kfun proc args) 43 (match (intmap-ref cps kfun) 44 (($ $kfun fsrc meta self ktail kentry) 45 (match (and kentry (intmap-ref cps kentry)) 46 (($ $kclause (? (lambda (arity) 47 (arity-matches? arity self proc args)) 48 arity) 49 kbody #f) 50 ;; This is a compatible $callk to a $kfun that checks its arity 51 ;; and has no alternate; arrange to elide the check. 52 (match (intmap-ref cps kbody) 53 (($ $kargs fnames fvars term) 54 (match term 55 (($ $continue (? (lambda (k) (eq? k ktail))) _ 56 ($ $callk kfun' 57 (? (lambda (proc') (eq? proc' self))) 58 (? (lambda (args) (equal? args fvars))))) 59 ;; This function already trampolines out to another 60 ;; function; forward this call there. Could recurse but 61 ;; we shouldn't need to, and we don't so as to avoid 62 ;; divergence. 63 (with-cps cps 64 (build-exp 65 ($callk kfun' proc args)))) 66 (_ 67 ;; Define a new unchecked function containing the body of 68 ;; this function. 69 (let ((self' (and self (fresh-var))) 70 (fvars' (map (lambda (_) (fresh-var)) fvars))) 71 (with-cps cps 72 ;; Entry of new kfun' is the $kargs kbody. 73 (letk kfun' ($kfun fsrc meta self ktail kbody)) 74 (letk ktail' ($ktail)) 75 (letk kbody' ($kargs fnames fvars' 76 ($continue ktail' fsrc 77 ($callk kfun' self' fvars')))) 78 (letk kentry' ($kclause ,arity kbody' #f)) 79 (setk kfun ($kfun fsrc meta self' ktail' kentry')) 80 ;; Dispatch source $callk to new kfun'. 81 (build-exp 82 ($callk kfun' proc args))))))))) 83 (_ 84 ;; Either this is already a $callk to a "raw" $kfun (one that 85 ;; doesn't check its arity), in which case we're good; or a call 86 ;; with possibly incompatible arity, or a call to a case-lambda, 87 ;; in which case we punt for now. 88 (with-cps cps 89 (build-exp ($callk kfun proc args)))))))) 90 91;; This transformation removes references to arity-checking $kfun's, but 92;; doesn't remove them, leaving that to renumbering or DCE to fix up. 93(define (elide-arity-checks cps) 94 (with-fresh-name-state cps 95 (persistent-intmap 96 (intmap-fold 97 (lambda (label cont cps) 98 (match cont 99 (($ $kargs names vars 100 ($ $continue k src ($ $callk kfun proc args))) 101 (with-cps cps 102 (let$ exp (maybe-elide-arity-check kfun proc args)) 103 (setk label ($kargs names vars 104 ($continue k src ,exp))))) 105 (_ cps))) 106 (persistent-intmap cps) 107 (transient-intmap cps))))) 108