home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / scanner.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  10.0 KB  |  319 lines
  1. (herald scanner (env tsys))
  2.  
  3. ;;; Heap and Stack Scanner
  4.  
  5. ;;; This code is not GC safe, it uses illegal pointers.
  6.  
  7. ;;;===========================================================================
  8.  
  9. ;;; Useful scanning procedures.
  10.  
  11. ;;; Find all the pointers that point to THING.
  12.  
  13. (define (heap-find-it pred)
  14.   (scan-heap (find-it pred)))
  15.  
  16. (define (find-it pred)
  17.   (lambda (ptr h-offset type o-offset)
  18.     (cond ((pred ptr)
  19.            (format t "~&Obj= ~a  @~D: ~S(~D)~%"
  20.                    ptr h-offset type o-offset)
  21.            (breakpoint)))))
  22.  
  23.  
  24.  
  25. ;;; Find all unreasonable pointers.  Anything that points anywhere
  26. ;;; in the stack space (including beyond the current stack top)
  27. ;;; is considered reasonable.
  28.  
  29. (define (reasonable-check)
  30.   (scan-heap reasonable-check-proc))
  31.  
  32. (define (reasonable-check-proc ptr h-offset type o-offset)
  33.   (if (not (reasonable?? ptr))
  34.       (format t "~&~D: ~S(~D)~%"
  35.               h-offset type o-offset)))
  36.  
  37. (define (reasonable?? ptr)
  38.   (or (reasonable? ptr)
  39.       (template-header? ptr)
  40.       (let ((num (descriptor->fixnum ptr)))
  41.         (and (fx>= num (descriptor->fixnum
  42.                         ;;(vref *boot-args* 4)  ; Aargh!!!
  43.                         (system-global slink/boot-args)))
  44.              (fx<= num (process-global task/stack))))))
  45.  
  46. ;;; Print out the heap.  
  47.  
  48. (define (print-it ptr h-offset type o-offset)
  49.   (ignore h-offset type o-offset)
  50.   (z-print ptr (standard-output))
  51.   (vm-newline (standard-output)))
  52.  
  53. ;;; Do nothing
  54.  
  55. (define (null-proc #f #f #f #f) nil)
  56.  
  57. ;;; Scan the heap looking at pointers
  58.  
  59. (define (scan-heap ptr-proc)
  60.   (let ((base     (area-base (current-area)))
  61.         (frontier (process-global task/area-frontier)))
  62.     (scan base frontier (pointer-check-proc ptr-proc))))
  63.  
  64. (define (pointer-check-proc ptr-proc)
  65.   (lambda (ptr offset ptrs scrs type)
  66.     (ignore scrs)
  67.     (if (memq? type '(closure pair))
  68.         (ptr-proc (extend-header ptr) offset type -1))
  69.     (scan-slots ptr offset ptrs ptr-proc type)))
  70.  
  71. (define (scan-slots ptr offset size ptr-proc type)
  72.   (do ((i 0 (fx+ i 1)))
  73.       ((fx>= i size))
  74.     (ptr-proc (extend-elt ptr i) offset type i)))
  75.  
  76. ;;;===========================================================================
  77. ;;; Impure area scanning
  78.  
  79. (define (scan-impure-area ptr-proc)
  80.   (scan (system-global slink/initial-impure-base)
  81.         (system-global slink/initial-impure-memory-end)
  82.         (pointer-check-proc ptr-proc)))
  83.  
  84. (define (impure-find-it pred)
  85.   (scan-impure-area (find-it pred)))
  86.  
  87.  
  88. ;;;===========================================================================
  89.  
  90. ;;; Stack Scanning
  91.  
  92. ;;;   The stack is just like the heap except that currently it contains only
  93. ;;; closures and fault frames.
  94.  
  95. (define (scan-stack obj-proc)
  96.   (let ((stack-base (process-global task/stack))
  97.         (top-of-stack (current-continuation)))
  98.     (scan top-of-stack stack-base obj-proc)))
  99.  
  100. ;;;===========================================================================
  101.  
  102. ;;; Heap Scanning
  103.  
  104. ;;; The actual scanning procedure.  BASE is an extend pointer to
  105. ;;; the beginning of the area to be scanned.  LIMIT is the size
  106. ;;; of the area (in cells) to be scanned.  OBJECT-PROC is a procedure
  107. ;;; of five arguments that is called on every pointer in the area
  108. ;;; scanned:
  109. ;;;    (OBJECT-PROC PTR OFFSET PTRS SCRS TYPE)
  110. ;;; PTR is the current value.  H-OFFSET is the offset from BASE
  111. ;;; of PTR.  PTRS and SCRS are the number of the object's pointer
  112. ;;; and scratch slots.  TYPE is a symbol describing the type of
  113. ;;; the object.  Currently TYPE in one of CLOSURE, FAULT-FRAME,
  114. ;;; PAIR, UNIT, GENERAL-VECTOR, STRING-SLICE, CELL, WEAK, VCELL,
  115. ;;; VFRAME, RATIO, BIGNUM, TEXT, FOREIGN, DOUBLE-FLOAT, BYTEV, and
  116. ;;; maybe a few others.  Look at the immediate dispatch below.
  117. ;++ GC defer around this.
  118.  
  119.  
  120. (define (scan base limit object-proc)
  121.   (format t "~&base= (~D) ~A~&start= ~D limit= ~D size= ~D~%"
  122.             (object-hash base)
  123.             base
  124.             (descriptor->fixnum base)
  125.             limit
  126.             (fx- limit (descriptor->fixnum base))) 
  127.   (real-scan base limit object-proc))
  128.  
  129. (define (real-scan base limit object-proc)
  130.   (let* ((start (descriptor->fixnum base))
  131.          (size (fx- (fx- limit start) 1)))
  132.     (iterate loop ((offset -1) (count 0))
  133.       (cond ((fx>= offset size) count)
  134.             (else
  135.              (let ((ptr (make-pointer base offset)))
  136.                (receive (ptrs scrs type)
  137.                         (scan-object-size ptr)
  138.                  (object-proc ptr offset ptrs scrs type)
  139.                  (loop (fx+ offset (fx+ 1 (fx+ ptrs scrs)))
  140.                        (fx+ count 1)))))))))
  141.  
  142. ;;;   Get the size and type of PTR.  This dispatches on the header.
  143. ;;; The only thing HEADER cannot be is a template header.  PTR is either a
  144. ;;; closure, an immediate with a header, or a pair.  The appropriate procedure
  145. ;;; is called for each.
  146.  
  147. (define (scan-object-size ptr)
  148.   (let ((header (extend-header ptr)))
  149.     (cond ((and (template-header? header)   ; 68000 requires this first
  150.                 (not (fixnum? header)))
  151.            (error "extend ~S with template header #x~X~%" ptr header))
  152.           ((template? header)
  153.            (scan-closure ptr header))
  154.           ((and (immediate? header)
  155.                 (not (or (char? header)
  156.                          ;++ flush when true changed
  157.                          (eq? header t))))
  158.            ((vref *scan-dispatch-vector* (header-type header)) ptr))
  159.           (else
  160.            (return 1 0 'pair)))))
  161.  
  162. ;;;   Scan a closure first checking that it is not supposed to be inside some
  163. ;;; other closure.
  164.  
  165. (define (scan-closure ptr template)
  166.   (cond ((template-internal-bit? template)
  167.          (error "internal closure ~S not inside.~%" ptr))
  168.         (else
  169.          (return (template-pointer-slots template)
  170.                  (template-scratch-slots template)
  171.                  'closure))))
  172.  
  173. ;;;===========================================================================
  174.  
  175. ;;; Scanning immediate objects.  
  176. ;;;   The procedures for scanning immediate objects are put into a dispatch
  177. ;;; vector indexed by the header types of the objects.  Scanning is just
  178. ;;; a matter of pulling the appropriate procedure out of the vector.
  179.  
  180. (define *scan-dispatch-vector* (make-vector %%number-of-immediate-types))
  181.  
  182. ;;;    Initialize the dispatch vector.  This is called when the file is loaded.
  183. ;;; See the last line of the file.  The vector is first filled with SCAN-ERROR
  184. ;;; and then the individual scanner procedures are installed.
  185.  
  186. (define (initialize-immediate-scanners)
  187.   (let ((scanners
  188.         `(
  189.          ; (,header/char           ,scan-char)  ; chars are only inside other objects
  190.           (,header/unit           ,scan-unit)
  191.           (,header/text           ,scan-text)
  192.           (,header/general-vector ,scan-general-vector)
  193.           (,header/slice          ,scan-string-slice)
  194.           (,header/symbol         ,scan-symbol)
  195.           (,header/bytev          ,scan-bytev)
  196.           (,header/foreign         ,scan-foreign)
  197.           (,header/template       ,scan-template)
  198.           (,header/cell           ,scan-cell)
  199.          ; (,header/weak           ,scan-weak)
  200.           (,header/weak-cell      ,scan-weak-cell)
  201.           (,header/weak-set       ,scan-weak-set)
  202.           (,header/weak-alist     ,scan-weak-alist)
  203.           (,header/weak-table     ,scan-weak-table)
  204.          ; (,header/task           ,scan-error)
  205.          ; (,header/true           ,scan-error) ; true only exists inside other objects
  206.           (,header/vcell          ,scan-vcell)
  207.           (,header/vframe         ,scan-vframe)
  208.           (,header/fault-frame     ,scan-fault-frame)
  209.  
  210.           ;; Numbers
  211.           (,header/bignum         ,scan-bignum)
  212.          ; (,header/short-float    ,scan-error) ;unimplemented
  213.           (,header/double-float   ,scan-double-float)
  214.           (,header/single-float   ,scan-single-float)
  215.           (,header/ratio          ,scan-ratio)
  216. ;          (,header/complex        ,scan-complex)
  217.           )))
  218.     (vector-fill *scan-dispatch-vector* scan-error)
  219.     (walk (lambda (x) (set (vector-elt *scan-dispatch-vector*
  220.                                        (fixnum-ashr (car x) 2))
  221.                            (cadr x)))
  222.           scanners)))
  223.  
  224. ;;; The default scan procedure for immediate objects.
  225.  
  226. (define (scan-error ptr)
  227.   (error "no scan method for immediate ~A~%" ptr))
  228.  
  229. ;;; All of the various scanning procedures for immediate objects.  These are
  230. ;;; all simple and straight forward (but not necessarily correct).
  231.  
  232. (define (scan-template ptr)
  233.   (error "immediate with template header ~A~%" ptr))
  234.  
  235. (define (scan-bytev ptr)
  236.   (return 0 (bytev-cells ptr) 'bytev))
  237.  
  238. (define (scan-text ptr)
  239.   (return 0 (bytev-cells ptr) 'text))
  240.  
  241. (define (scan-symbol ptr)
  242.   (return 0 (bytev-cells ptr) 'symbol))
  243.  
  244. (define (scan-bignum ptr)
  245.   (return 0 (bignum-length ptr) 'bignum))
  246.  
  247. (define (scan-foreign ptr)
  248.   (ignore ptr)
  249.   (return 1 1 'foreign))
  250.  
  251. (define (scan-unit ptr)
  252.   (return (unit-length ptr) 0 'unit))
  253.  
  254. (define (scan-general-vector ptr)
  255.   (return (vector-length ptr) 0 'general-vector))
  256.  
  257. (define (scan-string-slice ptr)
  258.   (ignore ptr)
  259.   (return 1 1 'string-slice))
  260.  
  261. (define (scan-cell ptr)
  262.   (ignore ptr)
  263.   (return 1 0 'cell))
  264.  
  265. (define (scan-weak ptr)
  266.   (ignore ptr)
  267.   (return 1 0 'weak))
  268.  
  269. (define (scan-weak-cell ptr)
  270.   (ignore ptr)
  271.   (return 1 0 'weak-cell))
  272.  
  273. (define (scan-weak-set ptr)
  274.   (ignore ptr)
  275.   (return 1 0 'weak-set))
  276.  
  277. (define (scan-weak-alist ptr)
  278.   (ignore ptr)
  279.   (return 1 0 'weak-alist))
  280.  
  281. (define (scan-weak-table ptr)
  282.   (ignore ptr)
  283.   (return 2 0 'weak-table))
  284.  
  285. (define (scan-vcell ptr)
  286.   (ignore ptr)
  287.   (return %%vcell-size 0 'vcell))
  288.  
  289. (define (scan-vframe ptr)
  290.   (return (vframe-pointer-slots ptr)
  291.           (vframe-scratch-slots ptr)
  292.           'vframe))
  293.                                
  294. (define (scan-fault-frame ptr)
  295.   (return 0
  296.           (fault-frame-slots ptr)
  297.           'fault-frame))
  298.  
  299.  
  300. (define (scan-double-float ptr)
  301.   (ignore ptr)
  302.   (return 0 2 'double-float))
  303.  
  304. (define (scan-single-float ptr)
  305.   (ignore ptr)
  306.   (error "single cell floats are unimplemented."))
  307.  
  308. (define (scan-ratio ptr)
  309.   (ignore ptr)
  310.   (return 2 0 'ratio))
  311.  
  312. (define (scan-complex ptr)
  313.   (ignore ptr)
  314.   (error "complex numbers are unimplemented."))
  315.  
  316. ;;; Do the initializing.
  317.  
  318. (initialize-immediate-scanners)
  319.