specialize-primcalls.scm 6.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2013-2015, 2017-2018 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. ;;; Some bytecode operations can encode an immediate as an operand.
  19. ;;; This pass tranforms generic primcalls to these specialized
  20. ;;; primcalls, if possible.
  21. ;;;
  22. ;;; Code:
  23. (define-module (language cps specialize-primcalls)
  24. #:use-module (ice-9 match)
  25. #:use-module (language cps)
  26. #:use-module (language cps utils)
  27. #:use-module (language cps intmap)
  28. #:export (specialize-primcalls))
  29. (define (compute-defining-expressions conts)
  30. (define (meet-defining-expressions old new)
  31. ;; If there are multiple definitions and they are different, punt
  32. ;; and record #f.
  33. (if (equal? old new)
  34. old
  35. #f))
  36. (persistent-intmap
  37. (intmap-fold (lambda (label cont defs)
  38. (match cont
  39. (($ $kargs _ _ ($ $continue k src exp))
  40. (match (intmap-ref conts k)
  41. (($ $kargs (_) (var))
  42. (intmap-add! defs var exp meet-defining-expressions))
  43. (_ defs)))
  44. (_ defs)))
  45. conts
  46. empty-intmap)))
  47. (define (compute-constant-values conts)
  48. (let ((defs (compute-defining-expressions conts)))
  49. (persistent-intmap
  50. (intmap-fold
  51. (lambda (var exp out)
  52. (match exp
  53. (($ $primcall (or 'load-f64 'load-u64 'load-s64) val ())
  54. (intmap-add! out var val))
  55. ;; Punch through type conversions to allow uadd to specialize
  56. ;; to uadd/immediate.
  57. (($ $primcall 'scm->f64 #f (val))
  58. (let ((f64 (intmap-ref out val (lambda (_) #f))))
  59. (if (and f64 (number? f64) (inexact? f64) (real? f64))
  60. (intmap-add! out var f64)
  61. out)))
  62. (($ $primcall (or 'scm->u64 'scm->u64/truncate) #f (val))
  63. (let ((u64 (intmap-ref out val (lambda (_) #f))))
  64. (if (and u64 (number? u64) (exact-integer? u64)
  65. (<= 0 u64 #xffffFFFFffffFFFF))
  66. (intmap-add! out var u64)
  67. out)))
  68. (($ $primcall 'scm->s64 #f (val))
  69. (let ((s64 (intmap-ref out val (lambda (_) #f))))
  70. (if (and s64 (number? s64) (exact-integer? s64)
  71. (<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF))
  72. (intmap-add! out var s64)
  73. out)))
  74. (_ out)))
  75. defs
  76. (intmap-fold (lambda (var exp out)
  77. (match exp
  78. (($ $const val)
  79. (intmap-add! out var val))
  80. (_ out)))
  81. defs
  82. empty-intmap)))))
  83. (define (specialize-primcalls conts)
  84. (let ((constants (compute-constant-values conts)))
  85. (define (uint? var)
  86. (let ((val (intmap-ref constants var (lambda (_) #f))))
  87. (and (exact-integer? val) (<= 0 val))))
  88. (define (u64? var)
  89. (let ((val (intmap-ref constants var (lambda (_) #f))))
  90. (and (exact-integer? val) (<= 0 val #xffffFFFFffffFFFF))))
  91. (define (num? var)
  92. (number? (intmap-ref constants var (lambda (_) #f))))
  93. (define (s64? var)
  94. (let ((val (intmap-ref constants var (lambda (_) #f))))
  95. (and (exact-integer? val)
  96. (<= (- #x8000000000000000) val #x7fffFFFFffffFFFF))))
  97. (define (f64? var)
  98. (let ((val (intmap-ref constants var (lambda (_) #f))))
  99. (and (number? val) (inexact? val) (real? val))))
  100. (define (specialize-primcall name param args)
  101. (define (rename name)
  102. (build-exp ($primcall name param args)))
  103. (define-syntax compute-constant
  104. (syntax-rules ()
  105. ((_ (c exp) body)
  106. (let* ((c (intmap-ref constants c)) (c exp)) body))
  107. ((_ c body) (compute-constant (c c) body))))
  108. (define-syntax-rule (specialize-case (pat (op c (arg ...))) ...)
  109. (match (cons name args)
  110. (pat
  111. (let* ((param* (intmap-ref constants c))
  112. (param (if param (cons param param*) param*)))
  113. (build-exp ($primcall 'op param (arg ...)))))
  114. ...
  115. (_ #f)))
  116. (specialize-case
  117. (('allocate-words (? uint? n)) (allocate-words/immediate n ()))
  118. (('allocate-pointerless-words (? uint? n))
  119. (allocate-pointerless-words/immediate n ()))
  120. (('scm-ref o (? uint? i)) (scm-ref/immediate i (o)))
  121. (('scm-set! o (? uint? i) x) (scm-set!/immediate i (o x)))
  122. ;; Assume (tail-)pointer-ref/immediate can always be emitted directly.
  123. (('word-ref o (? uint? i)) (word-ref/immediate i (o)))
  124. (('word-set! o (? uint? i) x) (word-set!/immediate i (o x)))
  125. (('add x (? num? y)) (add/immediate y (x)))
  126. (('add (? num? y) x) (add/immediate y (x)))
  127. (('sub x (? num? y)) (sub/immediate y (x)))
  128. (('uadd x (? uint? y)) (uadd/immediate y (x)))
  129. (('uadd (? uint? y) x) (uadd/immediate y (x)))
  130. (('usub x (? uint? y)) (usub/immediate y (x)))
  131. (('umul x (? uint? y)) (umul/immediate y (x)))
  132. (('umul (? uint? y) x) (umul/immediate y (x)))
  133. (('scm->f64 (? f64? var)) (load-f64 var ()))
  134. (('scm->u64 (? u64? var)) (load-u64 var ()))
  135. (('scm->u64/truncate (? u64? var)) (load-u64 var ()))
  136. (('scm->s64 (? s64? var)) (load-s64 var ()))
  137. (('untag-fixnum (? s64? var)) (load-s64 var ()))
  138. (('untag-char (? u64? var)) (load-u64 var ()))
  139. ;; FIXME: add support for tagging immediate chars
  140. ;; (('tag-char (? u64? var)) (load-const var ()))
  141. ))
  142. (intmap-map
  143. (lambda (label cont)
  144. (match cont
  145. (($ $kargs names vars ($ $continue k src ($ $primcall name param args)))
  146. (let ((exp* (specialize-primcall name param args)))
  147. (if exp*
  148. (build-cont
  149. ($kargs names vars ($continue k src ,exp*)))
  150. cont)))
  151. (_ cont)))
  152. conts)))
  153. ;;; Local Variables:
  154. ;;; eval: (put 'specialize-case 'scheme-indent-function 0)
  155. ;;; End: