home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / wabbit / wabbit.scm < prev    next >
Text File  |  1999-01-02  |  16KB  |  430 lines
  1. #| -*- Scheme -*-
  2.  
  3. $Id: wabbit.scm,v 1.2 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1994, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Wabbit Hunting and Headhunting GC
  23. ;;; package: (gc-wabbit)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;;                                        ;;;
  29. ;;; WABBIT -- Wabbit hunting and headhunting frobbery.                ;;;
  30. ;;;                                        ;;;
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32.  
  33. (define (initialize-package!)
  34.   (set! index:gc-wabbit-descwiptor
  35.     (fixed-objects-vector-slot 'GC-WABBIT-DESCWIPTOR))
  36.   (install))
  37.  
  38.  
  39. (define (wabbit-hunt wabbit-descwiptor #!optional fudd-thunk)
  40.   "(WABBIT-DESCWIPTOR #!optional FUDD-THUNK)
  41.  
  42.    Procedure behavior:
  43.    ------------------
  44.  
  45.    Open wabbit season on wabbits matching WABBIT-DESCWIPTOR and go wabbit
  46.    hunting. Once all the wabbits have been wounded up, invoke FUDD-THUNK,
  47.    weturning the wesult of FUDD-THUNK as the wesult of the wabbit hunt.
  48.    
  49.    The optional FUDD-THUNK pawameter defaults to the value of the fluid
  50.    vawiable: *DEFAULT-FUDD-THUNK*, which defaults to just weturning the
  51.    wabbit buffer (which will have been swabbed upon return!).
  52.  
  53.    Explanation of parameters:
  54.    -------------------------
  55.  
  56.    A ``wabbit descwiptor'' is a 4-element vector:
  57.        ------------------------------------------------------------------------
  58.        0. Boolean hunt disable flag -- (a.k.a. ``duck season'' flag)
  59.                        avoid wabbit hunting and/or headhunting
  60.                        upon the next GC flip.
  61.  
  62.        1. Wabbit vector -- vector of object references to target objects
  63.                (a.k.a. ``wabbits'')
  64.  
  65.        2. Wabbit buffer -- vector into which wabbit sightings are recorded.
  66.                This must be of length (2 + twice wabbit vect len).
  67.  
  68.        3. Boolean headhunt enable flag -- if FALSE, no headhunt is performed.
  69.                       else this slot will be replaced by a
  70.                        headhunt collection upon completion
  71.                        of the headhunting wabbit hunt.
  72.        ------------------------------------------------------------------------
  73.    ****
  74.     NB    a) Both the WABBIT-VECTOR and the WABBIT-BUFFER must reside in the heap
  75.    ****         i.e., they may *not* reside in constant space or on the stack.
  76.     b) Both the wabbit buffer and the headhunt collection slots are zeroed
  77.         upon return, since they may contain unsafe pointers. Moreover, it
  78.         is unsafe for the FUDD-THUNK to return them or otherwise close over
  79.         them. Consider them only to be very fluid parameter sources for the
  80.         FUDD-THUNK.
  81.  
  82.    The ``wabbit buffer'' should be a vector of FALSEs before the wabbit hunting
  83.    is initiated. At the end of the wabbit hunt, the wabbit buffer contents will
  84.    be laid out as follows:
  85.      --------------------------------------------------------------------------
  86.      slot 0 = Boolean flag: TRUE  if all wabbit sightings were recorded in the
  87.                      wabbit buffer
  88.                 FALSE if the wabbit buffer was too small to accomo-
  89.                      date a record for each wabbit sighting.
  90.                      (In this case, the FUDD-THUNK should do a
  91.                       bit of cleanup work so the same wabbit
  92.                       hunt can be re-initiated later.)
  93.      slot 1 = Fixnum: number of wabbit sightings recorded in the wabbit buffer
  94.      slot 2 = Object reference: cite of first wabbit sighting (``wabbit hole'')
  95.      slot 3 = Number: offset into first sighting object where wabbit is hiding
  96.      --------------------------------------------------------------------------
  97.    ...and so on, with even-index slots containing wabbit holes and odd-index
  98.    slots, indices. Note that slot 1 should hold the index of the first even
  99.    slot that holds FALSE and all slots thereafter should likewise hold FALSE.
  100.  
  101.    A ``wabbit hole'' is normally a headed object reference (a pointer) but it
  102.    may in very rare circumstances be a ``wascally wabbit hole''. There are only
  103.    three kinds of wascally wabbit holes:
  104.     ---------------------------------------------------------------------------
  105.     1. Characters: these indicate references to wabbit holes in constant space.
  106.            To reify the character into a cell whose contents holds the
  107.            wabbit, apply CELLIFY to the slot ref that holds the char.
  108.            (NB: the char as printed holds only part of the addr; you
  109.             must vector-ref into the wabbit buffer to get all the
  110.             addr bits. This is incredible magic.)
  111.     2. Null  Refs: these indicate headless objects. They should never appear.
  112.     3. Stack Refs: these indicate objects on the control stack. Since we reify
  113.            the stack into the heap as part of the call to WABBIT-HUNT,
  114.            these too should never appear unless you are doing something
  115.            painfully obscure (and dangerous!).
  116.  
  117.     If you ever encounter Null or Stack wabbit holes, you may want to send a
  118.     friendly bug report (?) to bug-cscheme@zurich.ai.mit.edu with a repeatable
  119.     test script.
  120.     ---------------------------------------------------------------------------
  121.  
  122.    The ``headhunt collection'' is a vector of arbitrary (fixnum) length. It is
  123.    intended to contain a pointer to the head of every object in the heap which
  124.    has an object header (spec., numbers, Booleans, etc not included). If all
  125.    headed heap objects fit in the space available after the GC flip, then slot
  126.    0 of this headhunt collection is TRUE. If not, slot 0 is FALSE and the vec-
  127.    tor contains as many object head references as actually did fit.
  128.  
  129.  ************ Be verwy verwy careful when headhunting... if you are not careful
  130.  ** CAVEAT ** to release the headhunt collection (e.g., SET! it to FALSE) or if
  131.  ************ you gobble up too much intermediate state in traversing it, you
  132.           will exhaust the available heap space and go down in flames. This
  133.           is a very fragile system memory feature intended for only the
  134.           most ginger-fingered discriminating systems wizards. For instance
  135.           it may some day lead to a post-GC garbage scavenger. Nonetheless,
  136.           it readily lends itself to self abuse if not treated reverently.
  137.   "
  138.  
  139.   (cond ((or (default-object?       fudd-thunk)
  140.          (not           fudd-thunk))
  141.      (set!               fudd-thunk
  142.               *default-fudd-thunk*)))
  143.   (let (;;
  144.     ;; Uhm... force stack refs into heap during wabbit season; undo at exit
  145.     ;;      and should be careful not to hunt wabbits out of season
  146.     ;;
  147.     (call-within-wabbit-season-with-duck-season-return-continuation
  148.      call-with-current-continuation)
  149.     ;;
  150.     ;; gc-flip is the raw low-level wabbit hunt mechanism... the hunt flag
  151.     ;;       enabled in the wabbit-descwiptor forces an alternative
  152.     ;;       ucode gc-loop which goes a-huntin' varmits.
  153.     (%waw-wabbit-hunt gc-flip)
  154.     )
  155.     (wabbit-season! wabbit-descwiptor)
  156.     (call-within-wabbit-season-with-duck-season-return-continuation
  157.      (lambda (return-to-duck-season)
  158.        (%waw-wabbit-hunt)
  159.        (let ((killed-da-wittle-bunny-wabbits
  160.           (dynamic-wind
  161.            (lambda () 'unwind-protect)
  162.            fudd-thunk
  163.            ;;
  164.            ;; Make sure unsafe buffers are cleared before returning...
  165.            ;;
  166.            (lambda () (%swab-wad wabbit-descwiptor)))))
  167.      (return-to-duck-season killed-da-wittle-bunny-wabbits))))))
  168.  
  169.  
  170. (define *default-fudd-thunk*)        ; See install below
  171. (define (default-fudd-thunk)
  172.   (wabbit-descwiptor/wabbit-buffer (get-wabbit-descwiptor)))
  173.  
  174.  
  175. (define-integrable (%swab-wad wad)    ; swab the wabbit descwiptor but good
  176.   ;;
  177.   ;; Nullify wabbit buffer, leaving found-all-flag and first-null-index intact
  178.   ;;
  179.   (let ((wabbit-buffer (wabbit-descwiptor/wabbit-buffer          wad)))
  180.     (cond ((vector? wabbit-buffer)
  181.        (let ((buflen (vector-length wabbit-buffer)))
  182.          (subvector-fill! wabbit-buffer
  183.                   (min 2 buflen) ; fuddge
  184.                   buflen
  185.                   false)))))
  186.   ;;
  187.   ;; Drop headhunt collection by replacing it w/ the length of the collection,
  188.   ;;   negated if not a complete headhunt collection.
  189.   ;;
  190.   (let ((headhunt-coll (wabbit-descwiptor/headhunt-collection wad)))
  191.     (cond ((vector? headhunt-coll)
  192.        (let ((head-len  (vector-length headhunt-coll))
  193.          (complete? (vector-ref       headhunt-coll 0)))
  194.          (set-wabbit-descwiptor/headhunt-collection! wad
  195.                              (if complete?
  196.                                  head-len
  197.                                  (- head-len)))))))
  198.   unspecific)
  199.  
  200. ;; Wabbit Season and Duck Season
  201.  
  202. (define (wabbit-season! wabbit-descwiptor)
  203.   "(WABBIT-DESCWIPTOR)
  204.    Declare open season on wabbits matching our target descwiptor.
  205.    Returns the old wabbit descwiptor (possibly FALSE).
  206.   "
  207.   (%stuff-gc-wabbit-descwiptor! wabbit-descwiptor))
  208.  
  209. (define (duck-season!)
  210.   "()
  211.    Disable wabbit hunting... returns descwiptor from latest wabbit hunt.
  212.   "
  213.   (let ((current-wd (get-wabbit-descwiptor)))
  214.     (cond ((wabbit-descwiptor? current-wd)
  215.        (set-wabbit-descwiptor/hunt-disable-flag! current-wd true)
  216.        current-wd)
  217.       (else
  218.        (%stuff-gc-wabbit-descwiptor! false)))))
  219.  
  220. ;; Misc
  221.  
  222. (define (duck-season?)
  223.   (let ((current-wd (get-wabbit-descwiptor)))
  224.     (or (false? current-wd)
  225.     (not (wabbit-descwiptor? current-wd)) ; should not arise, but guard
  226.     (wabbit-descwiptor/hunt-disable-flag current-wd))))
  227.  
  228. (define (wabbit-season?)
  229.   (not      (duck-season?)))
  230.  
  231.  
  232. ;; Low-level bits
  233.  
  234. (define index:gc-wabbit-descwiptor)    ; See initialize-package! above
  235.  
  236. (define-integrable (get-wabbit-descwiptor)
  237.   (vector-ref (get-fixed-objects-vector) index:gc-wabbit-descwiptor))
  238.  
  239. (define-integrable (%stuff-gc-wabbit-descwiptor! value)
  240.   (let* ((fov (get-fixed-objects-vector))
  241.      (old (vector-ref fov index:gc-wabbit-descwiptor)))
  242.     (vector-set! fov index:gc-wabbit-descwiptor value)
  243.     old))
  244.  
  245.  
  246. ;; Very precarious indeed!
  247.  
  248. (define (cellify object)        
  249.   ((ucode-primitive primitive-object-set-type 2) (ucode-type cell)
  250.                          object))
  251.  
  252. ;;;
  253. ;;; Wabbit descwiptor data abstraction-- NB: 4-elt vector rep (ucode depend'cy)
  254. ;;;
  255.  
  256. (define-integrable (wabbit-descwiptor? object)
  257.   (and (vector? object) (fix:= (vector-length object) 4)))
  258.  
  259. (define-structure
  260.   (            wabbit-descwiptor
  261.    (conc-name        wabbit-descwiptor/)
  262.    ;;(name       'wabbit-descriptor) ;; unnamed [i.e., not tagged]
  263.    (type vector))
  264.   (hunt-disable-flag    true         READ-ONLY false TYPE boolean)
  265.   (wabbit-vector    (vector)     READ-ONLY false TYPE vector)
  266.   (wabbit-buffer    (vector false 2) READ-ONLY false TYPE vector)
  267.   (headhunt-enable-flag false         READ-ONLY false TYPE boolean)
  268.   )
  269.  
  270. ;; Structure accessor aliases...
  271.  
  272. ;; after the hunt, the flag is replaced by a headhunt collection
  273.  
  274. (define-integrable
  275.   (wabbit-descwiptor/headhunt-collection  wabbit-descwiptor)
  276.   (wabbit-descwiptor/headhunt-enable-flag wabbit-descwiptor))
  277.  
  278. (define-integrable
  279.   (set-wabbit-descwiptor/headhunt-collection!  wabbit-descwiptor new-value)
  280.   (set-wabbit-descwiptor/headhunt-enable-flag! wabbit-descwiptor new-value))
  281.  
  282. ;;;
  283. ;;; Headhunting frobbery... special case of wabbit hunting: no wascally wabbits
  284. ;;;
  285.  
  286. (define (headhunt  #!optional headhunt-fudd-thunk headhunt-wabbit-descwiptor)
  287.   (cond ((or (default-object? headhunt-fudd-thunk)
  288.          (not          headhunt-fudd-thunk))
  289.      (set!              headhunt-fudd-thunk
  290.              *default-headhunt-fudd-thunk*))
  291.     )
  292.   (cond ((or (default-object?              headhunt-wabbit-descwiptor)
  293.          (not                  headhunt-wabbit-descwiptor))
  294.      (set!                      headhunt-wabbit-descwiptor
  295.                      *default-headhunt-wabbit-descwiptor*))
  296.     )
  297.   (wabbit-hunt                      headhunt-wabbit-descwiptor
  298.                   headhunt-fudd-thunk))
  299.  
  300.  
  301. (define *default-headhunt-fudd-thunk*)          ; See install below
  302. (define (default-headhunt-fudd-thunk)
  303.   ;;   ,
  304.   ;; Tres unsafe raven... lets headhunt collection escape the headhunt!
  305.   ;;
  306.   (wabbit-descwiptor/headhunt-collection (get-wabbit-descwiptor)))
  307.  
  308. (define *default-headhunt-wabbit-descwiptor*) ; See install below
  309. (define (default-headhunt-wabbit-descwiptor)
  310.   (make-wabbit-descwiptor false         ; hunt       disable flag disabled
  311.               (vector)     ; wabbit descwiptor null
  312.               (vector '? 'N) ; wabbit buffer     null-ish
  313.               true         ; headhunt enable flag     enabled
  314.               ))
  315.  
  316.  
  317.  
  318. ;;; fini
  319.  
  320. (define (install)
  321.   (set!         *default-fudd-thunk*
  322.           default-fudd-thunk)
  323.   (set!         *default-headhunt-fudd-thunk*
  324.           default-headhunt-fudd-thunk)
  325.   (set!         *default-headhunt-wabbit-descwiptor*
  326.          (default-headhunt-wabbit-descwiptor))
  327.   )
  328.  
  329. ;;;
  330. ;;; Sample usage (and mis-usage)
  331. ;;;
  332.  
  333. ;; handy util for debuggery
  334. ;;
  335. ;;(define memory-ref (make-primitive-procedure 'primitive-object-ref))
  336.  
  337.  
  338. #| Sample wreckless wabbit hunt... (does not swab the wabbit buffer)
  339.   --------------------------------
  340. (define foobarbaz (cons 'a 'b))
  341.  
  342. (begin
  343.   (wabbit-season!
  344.    (make-wabbit-descwiptor false           ; hunt     disable flag disabled
  345.                (vector foobarbaz)  ; wabbit vector
  346.                (make-vector 10 #f) ; wabbit buffer
  347.                false           ; headhunt enable flag disabled
  348.                ))
  349.   'be-careful!)
  350.  
  351. (gc-flip)
  352.  
  353. (define done (duck-season!))
  354.  
  355. (pp done)  ; lookin' for trouble
  356.  
  357. ;returns: #(#t #((a . b)) #(#t 4 (foobarbaz a . b) 1 () () () () () ()) ())
  358. |#
  359.  
  360.  
  361. #| Sample non-wreckless wabbit hunt... (safe wabbit hole count)
  362.   ------------------------------------
  363. (wabbit-hunt
  364.  (make-wabbit-descwiptor false             ; hunt    disable flag disabled
  365.              (vector foobarbaz)  ; wabbit vector
  366.              (make-vector 10 #f) ; wabbit buffer
  367.              false             ; headhunt enable flag disabled
  368.              ))
  369.  
  370. ; evaluated repeatedly... (stable wabbit hole count... holes swabbed upon exit)
  371. ;
  372. ;Value 31: #(#t 6 () () () () () () () ())  ; - 6 = wabbit hole count + 2
  373. ;Value 32: #(#t 6 () () () () () () () ())
  374. ;Value 33: #(#t 6 () () () () () () () ())
  375. |#
  376.  
  377. #| Sample dangerous wabbit hunt... (fudd thunk exposes the wabbit holes...hash)
  378.   -----------------------------
  379. (wabbit-hunt
  380.  (make-wabbit-descwiptor false             ; hunt    disable flag disabled
  381.              (vector foobarbaz)  ; wabbit vector
  382.              (make-vector 10 #f) ; wabbit buffer
  383.              false             ; headhunt enable flag disabled
  384.              )
  385.  (named-lambda (exposing-fudd-thunk)
  386.    (let* ((wabbuf (wabbit-descwiptor/wabbit-buffer (get-wabbit-descwiptor)))
  387.       (got-em-all?       (vector-ref wabbuf 0))
  388.       (last-hole-index (vector-ref wabbuf 1)))
  389.      (display "\n; #(")
  390.      (do ((index 2 (1+ index)))
  391.      ((>= index last-hole-index)
  392.       (if got-em-all?
  393.           (display ")\n; Th-th-th-that's all folks!")
  394.           (display ")\n; And many more.... maybe?!?"))
  395.       (newline))
  396.        (write (vector-ref wabbuf index)) ; DANGER! WRITE hashes output.
  397.        (write-char #\Space)))))
  398.  
  399. ; evaluated repeatedly... (stable display)
  400.  
  401. ; #((foobarbaz a . b) 1 #((a . b)) 1 )
  402. ; Th-th-th-that's all folks!
  403. ;No value
  404.  
  405. ; #((foobarbaz a . b) 1 #((a . b)) 1 )
  406. ; Th-th-th-that's all folks!
  407. ;No value
  408.  
  409. ; #((foobarbaz a . b) 1 #((a . b)) 1 )
  410. ; Th-th-th-that's all folks!
  411. ;No value
  412.  
  413. ; #((foobarbaz a . b) 1 #((a . b)) 1 )
  414. ; Th-th-th-that's all folks!
  415. ;No value
  416. |#
  417.  
  418. #| Sample semi-wreckless headhunt... (default headhunt-fudd-thunk exposes coll)
  419.   -------------------------------
  420.  
  421. (begin (headhunt)
  422.        (wabbit-descwiptor/headhunt-enable-flag (get-wabbit-descwiptor)))
  423.  
  424. ; evaluated repeatedly... (stable head count... if negative, partial count)
  425. ;
  426. ;Value: 23648
  427. ;Value: 23648
  428. ;Value: 23648
  429. |#
  430.