home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / VM / HEAP-STA.SCM < prev    next >
Text File  |  1992-06-17  |  6KB  |  238 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; This is file heap-stack.scm.
  5.  
  6. ; Implementing the interpreter stack as a stack of arguments with all
  7. ; continuations and environments in the heap.
  8.  
  9. (define *stack*               (unassigned))
  10. (define *bottom-of-stack*     (unassigned))
  11. (define *stack-limit*         (unassigned))
  12.  
  13. (define maximum-stack-args       63)
  14. (define arg-stack-overflow-nargs (%+ maximum-stack-args 1))
  15.  ; APPLY needs a little extra room
  16. (define required-stack-arg-count (%+ maximum-stack-args 1))
  17.  
  18. ;;; Measurements
  19.  
  20. (define copy/closure 0) ; leave these as there are still references lying around
  21. (define copy/overflow 1)
  22. (define copy/preserve 2)
  23.  
  24. ;(define *conts* 0)
  25. ;(define *conts-slots* 0)
  26. ;(define *conts-overflow* 0)
  27. ;(define *conts-overflow-slots* 0)
  28. ;(define *conts-preserved* 0)
  29. ;(define *conts-preserved-slots* 0)
  30. ;(define *conts-from-heap* 0)
  31. ;(define *conts-from-heap-slots* 0)
  32.  
  33. ;(define *envs* 0)
  34. ;(define *envs-slots* 0)
  35. ;(define *envs-closed* 0)
  36. ;(define *envs-closed-slots* 0)
  37. ;(define *envs-overflow* 0)
  38. ;(define *envs-overflow-slots* 0)
  39. ;(define *envs-preserved* 0)
  40. ;(define *envs-preserved-slots* 0)
  41.  
  42. ;(define (reset-stack-stats)
  43. ;  (set! *conts* 0)
  44. ;  (set! *conts-slots* 0)
  45. ;  (set! *conts-overflow* 0)
  46. ;  (set! *conts-overflow-slots* 0)
  47. ;  (set! *conts-preserved* 0)
  48. ;  (set! *conts-preserved-slots* 0)
  49. ;  (set! *conts-from-heap* 0)
  50. ;  (set! *conts-from-heap-slots* 0)
  51.  
  52. ;  (set! *envs* 0)
  53. ;  (set! *envs-slots* 0)
  54. ;  (set! *envs-closed* 0)
  55. ;  (set! *envs-closed-slots* 0)
  56. ;  (set! *envs-overflow* 0)
  57. ;  (set! *envs-overflow-slots* 0)
  58. ;  (set! *envs-preserved* 0)
  59. ;  (set! *envs-preserved-slots* 0)
  60. ;  )
  61.  
  62. (define (reset-stack-stats)
  63.   0)
  64.  
  65. (define (print-stack-stats port)
  66.   0)
  67.  
  68. ;(define (print-stack-stats port)
  69. ;  (let ((one-record (lambda (name count slots port)
  70. ;              (%newline port)
  71. ;              (%write-string "(" port)
  72. ;              (%write-string name port)
  73. ;              (%write-string " " port)
  74. ;              (%write-number count port)
  75. ;              (%write-number slots port)
  76. ;              (%write-string ")" port))))
  77. ;    (%newline port)
  78. ;    (%write-string "(continuations" port)
  79. ;    (one-record "made" *conts* *conts-slots* port)
  80. ;    (one-record "overflow" *conts-overflow* *conts-overflow-slots* port)
  81. ;    (one-record "preserved" *conts-preserved* *conts-preserved-slots* port)
  82. ;    (one-record "from-heap" *conts-from-heap* *conts-from-heap-slots* port)
  83. ;    (%write-string ")" port)
  84.  
  85. ;    (%newline port)
  86. ;    (%write-string "(environments" port)
  87. ;    (one-record "made" *envs* *envs-slots* port)
  88. ;    (one-record "closed" *envs-closed* *envs-closed-slots* port)
  89. ;    (one-record "overflow" *envs-overflow* *envs-overflow-slots* port)
  90. ;    (one-record "preserved" *envs-preserved* *envs-preserved-slots* port)
  91. ;    (%write-string ")" port)
  92. ;    (%newline port)
  93. ;    ))
  94.  
  95. ;;; Initializing
  96.  
  97. (define (initialize-stack)
  98.   (set! *stack* (addr-1+ *stack-end*)))
  99.  
  100. (define initial-stack-heap-space 0)
  101.  
  102. (define (reset-stack-pointer)
  103.   (set! *stack* (addr-1+ *stack-end*))
  104.   #f)   ; initial value of *cont*
  105.  
  106. (define (reserve-stack-space size)
  107.   0)
  108.  
  109. (define (enable-stack-reserve)
  110.   0)
  111.  
  112. (define (within-stack? p)
  113.   #f)
  114.  
  115. ; Space usage
  116.  
  117. (define push-size 1)
  118.  
  119. (define (stack-continuation-size cells)
  120.   (%+ (%+ cells 1)                 ; header
  121.       required-stack-arg-count))   ; pre-checking for pushed arguments
  122.  
  123. (define (available-on-stack? cells)
  124.   (available? cells))
  125.  
  126. (define preallocate-stack-space preallocate-heap-space)
  127.  
  128. (define check-stack-cons check-heap-cons)
  129.  
  130. (define ensure-stack-space ensure-space)
  131.  
  132. (define (ensure-env-space count)
  133.   (ensure-space (%+ count 2)))  ; header + superior environment
  134.  
  135. (define (ensure-heap-env-space count)
  136.   0)
  137.  
  138. (define (pop-args-into-heap-env count key)
  139.   0)
  140.  
  141. ; What to do with this?  Ignore?
  142.  
  143. (define *exception-space-used?* #f)
  144.  
  145. ; This is unsafe, but it shouldn't come up in running benchmarks
  146. (define (allow-exception-consing)
  147.   0)
  148.  
  149. (define (reserve-exception-space)
  150.   0)
  151.  
  152. ;;; Add CELLS cells onto the stack.
  153.  
  154. (define (stack-add cells)
  155.   (set! *stack* (addr- *stack* (cells->a-units cells))))
  156.  
  157. ;;; Pushing and popping
  158.  
  159. (define (push x)         ; Check for space is done when continuation is pushed
  160.   (store! *stack* x)
  161.   (stack-add 1))
  162.  
  163. (define (pop)
  164.   (stack-add -1)
  165.   (fetch *stack*))
  166.  
  167. ; Make a continuation in the heap and put the current argument stack in it.
  168. ; Resets the stack pointer.
  169.  
  170. (define (push-continuation-on-stack arg-count key)
  171.   (pop-args-into-heap stob/continuation
  172.               arg-count
  173.               continuation-cells
  174.               key))
  175.  
  176. ; Copy the arguments out of CONT and back onto the stack.
  177.  
  178. (define (pop-continuation-from-stack cont)
  179.   (let ((end (addr+ (address-after-header cont)
  180.             (cells->a-units continuation-cells)))
  181.     (start (addr+ (address-at-header cont)
  182.               (cells->a-units (continuation-length cont)))))
  183.     (do ((from start (addr-1+ from))
  184.      (to *stack-end* (addr-1+ to)))
  185.     ((addr< from end)
  186.      (set! *stack* to))
  187.       (store! to (fetch from)))))
  188.  
  189. (define (pop-args-into-env count key)
  190.   (pop-args-into-heap stob/vector count 1 key))
  191.  
  192. (define (pop-args-into-heap type count extra-slots key)
  193.   (let ((stob (make-stob type
  194.              (cells->bytes (%+ count extra-slots))
  195.              key)))
  196.     (copy-cells! (addr1+ *stack*)
  197.          (addr+ (cells->a-units extra-slots)
  198.             (address-after-header stob))
  199.          count)
  200.     (set! *stack* (addr-1+ *stack-end*))
  201.     stob))
  202.  
  203. ; Tracing the stack
  204.  
  205. (define (trace-stack)
  206.   (trace-locations (addr1+ *stack*) *stack-end*))
  207.  
  208. (define (arguments-on-stack)
  209.   (%+ -1 (a-units->cells (addr- *stack-end* *stack*))))
  210.  
  211. ; Dummy definitions.
  212.  
  213. (define (perserve-*env*)
  214.   0)
  215.  
  216. (define (move-args-above-cont cont nargs)
  217.   0)
  218.  
  219. (define (stack-size)
  220.   0)
  221.  
  222. (define (preserve-continuation cont key reason)
  223.   cont)
  224.  
  225. (define (preserve-*env*)
  226.   0)
  227.  
  228. (define (restore-continuation cont)
  229.   cont)
  230.  
  231. (define (get-continuation-from-heap)  ; should never be called
  232.   0)
  233.  
  234. (define (addr-1+ x)
  235.   (addr- x addressing-units-per-cell))
  236.  
  237.  
  238.