bytecode.scm 4.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138
  1. ;;; Bytecode
  2. ;; Copyright (C) 2013, 2017, 2018, 2020 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. ;;; Code:
  17. (define-module (language bytecode)
  18. #:use-module (ice-9 match)
  19. #:use-module ((srfi srfi-1) #:select (fold))
  20. #:export (instruction-list
  21. builtin-name->index
  22. builtin-index->name
  23. intrinsic-name->index
  24. intrinsic-index->name))
  25. (load-extension (string-append "libguile-" (effective-version))
  26. "scm_init_instructions")
  27. (load-extension (string-append "libguile-" (effective-version))
  28. "scm_init_vm_builtins")
  29. (load-extension (string-append "libguile-" (effective-version))
  30. "scm_init_intrinsics")
  31. (begin-deprecated
  32. (define (compute-instruction-arity name args)
  33. (define (first-word-arity word)
  34. (case word
  35. ((X32) 0)
  36. ((X8_S24) 1)
  37. ((X8_F24) 1)
  38. ((X8_C24) 1)
  39. ((X8_L24) 1)
  40. ((X8_S8_I16) 2)
  41. ((X8_S8_ZI16) 2)
  42. ((X8_S12_S12) 2)
  43. ((X8_S12_C12) 2)
  44. ((X8_S12_Z12) 2)
  45. ((X8_C12_C12) 2)
  46. ((X8_F12_F12) 2)
  47. ((X8_S8_S8_S8) 3)
  48. ((X8_S8_S8_C8) 3)
  49. ((X8_S8_C8_S8) 3)))
  50. (define (tail-word-arity word)
  51. (case word
  52. ((C32) 1)
  53. ((I32) 1)
  54. ((A32 AU32 AS32 AF32) 1)
  55. ((B32 BF32 BS32 BU32) 0)
  56. ((N32) 1)
  57. ((R32) 1)
  58. ((L32) 1)
  59. ((LO32) 1)
  60. ((C8_C24) 2)
  61. ((C8_S24) 2)
  62. ((C16_C16) 2)
  63. ((B1_C7_L24) 3)
  64. ((B1_X7_S24) 2)
  65. ((B1_X7_F24) 2)
  66. ((B1_X7_C24) 2)
  67. ((B1_X7_L24) 2)
  68. ((B1_X31) 1)
  69. ((X8_S24) 1)
  70. ((X8_F24) 1)
  71. ((X8_C24) 1)
  72. ((X8_L24) 1)))
  73. (match args
  74. ((arg0 . args)
  75. (fold (lambda (arg arity)
  76. (+ (tail-word-arity arg) arity))
  77. (first-word-arity arg0)
  78. args))))
  79. (define *macro-instruction-arities*
  80. '((cache-current-module! . (0 . 1))
  81. (cached-toplevel-box . (1 . 0))
  82. (cached-module-box . (1 . 0))))
  83. (define (compute-instruction-arities)
  84. (issue-deprecation-warning
  85. "`instruction-arity' is deprecated. Instead, use instruction-list directly
  86. if needed.")
  87. (let ((table (make-hash-table)))
  88. (for-each
  89. (match-lambda
  90. ;; Put special cases here.
  91. (('jtable . _)
  92. ;; No macro-instruction.
  93. #f)
  94. ((name op '! . args)
  95. (hashq-set! table name
  96. (cons 0 (compute-instruction-arity name args))))
  97. ((name op '<- . args)
  98. (hashq-set! table name
  99. (cons 1 (1- (compute-instruction-arity name args))))))
  100. (instruction-list))
  101. (for-each (match-lambda
  102. ((name . arity)
  103. (hashq-set! table name arity)))
  104. *macro-instruction-arities*)
  105. table))
  106. (define *instruction-arities* (delay (compute-instruction-arities)))
  107. (define-public (instruction-arity name)
  108. (hashq-ref (force *instruction-arities*) name)))
  109. (define *intrinsic-codes*
  110. (delay (let ((tab (make-hash-table)))
  111. (for-each (lambda (pair)
  112. (hashv-set! tab (car pair) (cdr pair)))
  113. (intrinsic-list))
  114. tab)))
  115. (define *intrinsic-names*
  116. (delay (let ((tab (make-hash-table)))
  117. (hash-for-each (lambda (k v) (hashq-set! tab v k))
  118. (force *intrinsic-codes*))
  119. tab)))
  120. (define (intrinsic-name->index name)
  121. (hashq-ref (force *intrinsic-codes*) name))
  122. (define (intrinsic-index->name index)
  123. (hashv-ref (force *intrinsic-names*) index))