guile-vm.scm 4.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2023 Free Software Foundation, Inc.
  3. ;;; This library is free software; you can redistribute it and/or modify it
  4. ;;; under the terms of the GNU Lesser General Public License as published by
  5. ;;; the Free Software Foundation; either version 3 of the License, or (at
  6. ;;; your option) any later version.
  7. ;;;
  8. ;;; This library is distributed in the hope that it will be useful, but
  9. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
  11. ;;; General Public License for more details.
  12. ;;;
  13. ;;; You should have received a copy of the GNU Lesser General Public License
  14. ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  15. ;;; Commentary:
  16. ;;;
  17. ;;; Backend-specific lowering and optimization when targetting Guile's
  18. ;;; bytecode virtual machine.
  19. ;;;
  20. ;;; Code:
  21. (define-module (language cps guile-vm)
  22. #:use-module (ice-9 match)
  23. #:use-module (language cps guile-vm loop-instrumentation)
  24. #:use-module (language cps guile-vm lower-primcalls)
  25. #:use-module (language cps guile-vm reify-primitives)
  26. #:use-module (system base target)
  27. #:export (make-lowerer
  28. available-optimizations
  29. target-symbol-hash
  30. target-symbol-hash-bits
  31. target-has-unbound-boxes?))
  32. ;; This hash function is originally from
  33. ;; http://burtleburtle.net/bob/c/lookup3.c by Bob Jenkins, May 2006,
  34. ;; Public Domain. No warranty.
  35. (define (jenkins-lookup3-hashword2 str)
  36. (define (u32 x) (logand x #xffffFFFF))
  37. (define (shl x n) (u32 (ash x n)))
  38. (define (shr x n) (ash x (- n)))
  39. (define (rot x n) (logior (shl x n) (shr x (- 32 n))))
  40. (define (add x y) (u32 (+ x y)))
  41. (define (sub x y) (u32 (- x y)))
  42. (define (xor x y) (logxor x y))
  43. (define (mix a b c)
  44. (let* ((a (sub a c)) (a (xor a (rot c 4))) (c (add c b))
  45. (b (sub b a)) (b (xor b (rot a 6))) (a (add a c))
  46. (c (sub c b)) (c (xor c (rot b 8))) (b (add b a))
  47. (a (sub a c)) (a (xor a (rot c 16))) (c (add c b))
  48. (b (sub b a)) (b (xor b (rot a 19))) (a (add a c))
  49. (c (sub c b)) (c (xor c (rot b 4))) (b (add b a)))
  50. (values a b c)))
  51. (define (final a b c)
  52. (let* ((c (xor c b)) (c (sub c (rot b 14)))
  53. (a (xor a c)) (a (sub a (rot c 11)))
  54. (b (xor b a)) (b (sub b (rot a 25)))
  55. (c (xor c b)) (c (sub c (rot b 16)))
  56. (a (xor a c)) (a (sub a (rot c 4)))
  57. (b (xor b a)) (b (sub b (rot a 14)))
  58. (c (xor c b)) (c (sub c (rot b 24))))
  59. (values a b c)))
  60. (define len (string-length str))
  61. (define (add-char x index)
  62. (add x (char->integer (string-ref str index))))
  63. (let ((init (add #xdeadbeef (add (shl len 2) 47))))
  64. (let lp ((i 0) (a init) (b init) (c init))
  65. (let ((remaining (- len i)))
  66. (cond
  67. ((< 3 remaining)
  68. (call-with-values (lambda ()
  69. (mix (add-char a i)
  70. (add-char b (+ i 1))
  71. (add-char c (+ i 2))))
  72. (lambda (a b c)
  73. (lp (+ i 3) a b c))))
  74. (else
  75. (let* ((a (if (<= 1 remaining) (add-char a i) a))
  76. (b (if (<= 2 remaining) (add-char b (+ i 1)) b))
  77. (c (if (<= 3 remaining) (add-char c (+ i 2)) c)))
  78. (final a b c))))))))
  79. (define (target-symbol-hash str)
  80. (call-with-values (lambda () (jenkins-lookup3-hashword2 str))
  81. (lambda (a b c)
  82. ;; The high 32 bits of the hash on a 64-bit platform are
  83. ;; equivalent to the hash on a 32-bit platform. The top two bits
  84. ;; are zero to allow the hash to fit in a fixnum.
  85. (ash (case (target-word-size)
  86. ((4) c)
  87. ((8) (logior (ash c 32) b))
  88. (else (error "unexpected target word size" (target-word-size))))
  89. -2))))
  90. (define target-symbol-hash-bits
  91. (- (* (target-word-size) 8) 2))
  92. (define (make-lowerer optimization-level opts)
  93. (lambda (exp env)
  94. (add-loop-instrumentation
  95. (reify-primitives
  96. (lower-primcalls exp)))))
  97. (define (available-optimizations)
  98. '())
  99. (define target-has-unbound-boxes? #t)