stack-check.scm 9.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330
  1. ; Part of Scheme 48 1.9. See file COPYING for notices and license.
  2. ; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
  3. ; This determines the maximum stack depth needed by a code vector.
  4. (define (maximum-stack-use code-vector)
  5. (cond ((not (= (code-vector-ref code-vector 0)
  6. (enum op protocol)))
  7. 0)
  8. ((= (code-vector-ref code-vector 1)
  9. nary-dispatch-protocol) ; has unjumped-to targets
  10. (stack-max code-vector
  11. 6
  12. 0
  13. 0
  14. (do ((i 2 (+ i 1))
  15. (r '() (let ((target (code-vector-ref code-vector i)))
  16. (if (= 0 target)
  17. r
  18. (cons (cons target 0) r)))))
  19. ((= i 6)
  20. r))))
  21. (else
  22. (stack-max code-vector
  23. (protocol-skip code-vector)
  24. 0
  25. 0
  26. '()))))
  27. (define (protocol-skip code-vector)
  28. (let ((protocol (code-vector-ref code-vector 1)))
  29. (cond ((or (= protocol two-byte-nargs-protocol)
  30. (= protocol two-byte-nargs+list-protocol))
  31. 4)
  32. ((= protocol args+nargs-protocol)
  33. 3)
  34. (else
  35. 2))))
  36. ;----------------
  37. ; A vector of procedures, one for each opcode.
  38. (define stack-delta (make-vector op-count #f))
  39. (define-syntax define-delta
  40. (syntax-rules ()
  41. ((define-delta opcode fun)
  42. (vector-set! stack-delta (enum op opcode) fun))))
  43. ; Handle the opcode at I. DEPTH is the current stack depth, MAXIMUM is the
  44. ; maximum so far, and JUMPS is a list of (<index> . <depth>) giving the stack
  45. ; depth at jump targets.
  46. (define (stack-max code-vector i depth maximum jumps)
  47. ((vector-ref stack-delta (code-vector-ref code-vector i))
  48. code-vector
  49. (+ i 1)
  50. depth
  51. maximum
  52. jumps))
  53. ; Do nothing and advance BYTE-SIZE bytes.
  54. (define (nothing byte-size)
  55. (lambda (code-vector i depth maximum jumps)
  56. (stack-max code-vector
  57. (+ i byte-size)
  58. depth
  59. maximum
  60. jumps)))
  61. ; Pop COUNT values from the stack and advance BYTE-SIZE bytes.
  62. (define (popper count byte-args)
  63. (lambda (code-vector i depth maximum jumps)
  64. (stack-max code-vector
  65. (+ i byte-args)
  66. (- depth count)
  67. maximum
  68. jumps)))
  69. ; Push COUNT values onto the stack and advance BYTE-SIZE bytes.
  70. (define (pusher count byte-args)
  71. (lambda (code-vector i depth maximum jumps)
  72. (stack-max code-vector
  73. (+ i byte-args)
  74. (+ depth count)
  75. (imax maximum (+ depth count))
  76. jumps)))
  77. ; Continue on at opcode I. This is used for opcodes that do not fall through
  78. ; to the next instruction. I is either the end of the code vector or the target
  79. ; of a jump or continuation.
  80. (define (continue code-vector i maximum jumps)
  81. (cond ((= i (code-vector-length code-vector))
  82. maximum)
  83. ((assq i jumps)
  84. => (lambda (pair)
  85. (stack-max code-vector i (cdr pair) maximum jumps)))
  86. ((= (code-vector-ref code-vector i)
  87. (enum op cont-data))
  88. (continue code-vector
  89. (+ i 4) ; how do I know this?
  90. maximum
  91. jumps))
  92. (else
  93. (assertion-violation 'continue "stack-max: no one jumps to target" i))))
  94. ; Skip BYTE-ARGS and then continue.
  95. (define (continuer byte-args)
  96. (lambda (code-vector i depth maximum jumps)
  97. (continue code-vector (+ i byte-args) maximum jumps)))
  98. ;----------------
  99. ; Two-byte offsets, here because it is used at top-level.
  100. (define (get-offset code pc)
  101. (+ (* (code-vector-ref code pc)
  102. byte-limit)
  103. (code-vector-ref code (+ pc 1))))
  104. ;----------------
  105. ; All the special opcodes
  106. (define-delta make-env (pusher environment-stack-size 2))
  107. ;(define-delta push (pusher 1 0))
  108. (define-delta pop (popper 1 0))
  109. (define-delta call (continuer 1))
  110. (define-delta big-call (continuer 2))
  111. (define-delta apply (continuer 2))
  112. (define-delta closed-apply (continuer 0))
  113. (define-delta with-continuation (nothing 0)) ; what the compiler requires
  114. (define-delta return (continuer 0))
  115. (define-delta values (continuer 2))
  116. (define-delta closed-values (continuer 0))
  117. (define-delta goto-template (continuer 2))
  118. (define-delta call-template (continuer 3))
  119. ; We should only reach PROTOCOL opcodes in continuations.
  120. (define-delta protocol
  121. (lambda (cv pc depth maximum jumps)
  122. (let ((protocol (code-vector-ref cv pc)))
  123. (if (= protocol call-with-values-protocol)
  124. (continue cv (+ pc 1) maximum jumps)
  125. (call-with-values
  126. (lambda ()
  127. (cond ((or (<= protocol 1)
  128. (= protocol ignore-values-protocol))
  129. (values 1 0))
  130. ((<= protocol maximum-stack-args)
  131. (values 1 protocol))
  132. ((= protocol two-byte-nargs+list-protocol)
  133. (values (+ (get-offset cv (+ pc 1))
  134. 1) ; the rest list
  135. 3))
  136. ((= protocol two-byte-nargs-protocol)
  137. (values (get-offset cv (+ pc 1))
  138. 3))
  139. (else
  140. (assertion-violation 'protocol "unknown protocol" protocol))))
  141. (lambda (bytes on-stack)
  142. (stack-max cv
  143. (+ pc bytes)
  144. (+ depth on-stack)
  145. (imax maximum (+ depth on-stack))
  146. jumps)))))))
  147. ; Peephole optimizations
  148. (define-delta push
  149. (lambda (cv pc depth maximum jumps)
  150. (if (= (enum op local0)
  151. (code-vector-ref cv pc))
  152. (begin
  153. (code-vector-set! cv (- pc 1) (enum op push-local0))
  154. (stack-max cv
  155. (+ pc 2)
  156. (+ depth 1)
  157. (imax maximum (+ depth 1))
  158. jumps))
  159. (stack-max cv
  160. pc
  161. (+ depth 1)
  162. (imax maximum (+ depth 1))
  163. jumps))))
  164. (define-delta local0
  165. (lambda (cv pc depth maximum jumps)
  166. (if (= (enum op push)
  167. (code-vector-ref cv (+ pc 1)))
  168. (begin
  169. (code-vector-set! cv (- pc 1) (enum op local0-push))
  170. (stack-max cv
  171. (+ pc 2)
  172. (+ depth 1)
  173. (imax maximum (+ depth 1))
  174. jumps))
  175. (stack-max cv
  176. (+ pc 1)
  177. depth
  178. maximum
  179. jumps))))
  180. ; Pop the given numbers of stack values.
  181. (define-delta make-stored-object
  182. (lambda (cv pc depth maximum jumps)
  183. (let ((args (code-vector-ref cv pc)))
  184. (stack-max cv (+ pc 2) (- depth (- args 1)) maximum jumps))))
  185. ; Skip over the environment specification.
  186. (define (flat-env-checker size fetch)
  187. (lambda (cv pc depth maximum jumps)
  188. (let ((include-*val*? (= 1 (code-vector-ref cv pc)))
  189. (count (fetch cv (+ pc 1))))
  190. (let loop ((i (+ pc 1 size))
  191. (count (if include-*val*?
  192. (- count 1)
  193. count)))
  194. (if (= count 0)
  195. (stack-max cv i depth maximum jumps)
  196. (let ((level-count (fetch cv (+ i 1))))
  197. (loop (+ i 1 size (* level-count size))
  198. (- count level-count))))))))
  199. (define-delta make-flat-env (flat-env-checker 1 code-vector-ref))
  200. (define-delta make-big-flat-env (flat-env-checker 2 get-offset))
  201. ; Temporarily puts COUNT values on the stack.
  202. (define-delta letrec-closures
  203. (lambda (cv pc depth maximum jumps)
  204. (let ((count (get-offset cv pc)))
  205. (stack-max cv
  206. (+ pc (* 2 (+ count 1)))
  207. depth
  208. (max maximum (+ depth count environment-stack-size))
  209. jumps))))
  210. ; Adds the target to the list of jumps.
  211. ; The -1 is to back up over the opcode.
  212. ; Could check that the we agree with the compiler on the size of the stack.
  213. (define-delta make-cont
  214. (lambda (code-vector i depth maximum jumps)
  215. (let ((target (+ i -1 (get-offset code-vector i))))
  216. (stack-max code-vector
  217. (+ i 2) ; eat offset
  218. (+ depth continuation-stack-size)
  219. (max maximum (+ depth continuation-stack-size))
  220. (cons (cons target depth) jumps)))))
  221. ; Add the jump target(s) and either fall-through or not.
  222. ; The -1 is to back up over the opcode.
  223. (define-delta jump-if-false
  224. (lambda (code-vector i depth maximum jumps)
  225. (let ((target (+ i -1 (get-offset code-vector i))))
  226. (stack-max code-vector
  227. (+ i 2) ; eat label
  228. depth
  229. maximum
  230. (cons (cons target depth) jumps)))))
  231. (define-delta jump
  232. (lambda (code-vector i depth maximum jumps)
  233. (let ((target (+ i -1 (get-offset code-vector i))))
  234. (continue code-vector
  235. (+ i 2) ; eat label
  236. maximum
  237. (cons (cons target depth) jumps)))))
  238. (define-delta computed-goto
  239. (lambda (code-vector i depth maximum jumps)
  240. (let ((count (code-vector-ref code-vector i))
  241. (base (- i 1)) ; back up over opcode
  242. (i (+ i 1)))
  243. (let loop ((c 0) (jumps jumps))
  244. (if (= c count)
  245. (stack-max code-vector
  246. (+ i (* 2 count))
  247. depth
  248. maximum
  249. jumps)
  250. (loop (+ c 1)
  251. (cons (cons (+ base (get-offset code-vector (+ i (* c 2))))
  252. depth)
  253. jumps)))))))
  254. ;----------------
  255. ; Fill in the `normal' opcodes using the information in OPCODE-ARG-SPECS.
  256. (define (stack-function arg-specs)
  257. (let loop ((specs arg-specs) (skip 0))
  258. (cond ((null? specs)
  259. (nothing skip))
  260. ((integer? (car specs))
  261. (if (> (car specs) 1)
  262. (popper (- (car specs) 1) skip)
  263. (nothing skip)))
  264. (else
  265. (loop (cdr specs) (+ skip (arg-spec-size (car specs))))))))
  266. (define (arg-spec-size spec)
  267. (case spec
  268. ((nargs byte stob junk) 1)
  269. ((two-bytes offset small-index index) 2)
  270. (else
  271. (assertion-violation 'arg-spec-size "unknown arg-spec" spec))))
  272. (do ((i 0 (+ i 1)))
  273. ((= i (vector-length stack-delta)))
  274. (if (not (vector-ref stack-delta i))
  275. (vector-set! stack-delta i (stack-function (vector-ref opcode-arg-specs i)))))
  276. ;----------------
  277. ; Utilities
  278. ; Much faster then Scheme's generic function.
  279. (define (imax x y)
  280. (if (< x y) y x))