elide-arity-checks.scm 4.4 KB

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