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