--- /dev/null
+#| -*- Scheme -*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/wabbit/wabbit.scm,v 1.1 1995/07/11 00:27:56 ziggy Exp $
+
+Copyright (c) 1994 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Wabbit Hunting and Headhunting GC
+;;; package: (gc-wabbit)
+
+(declare (usual-integrations))
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ;;;
+;;; WABBIT -- Wabbit hunting and headhunting frobbery. ;;;
+;;; ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (initialize-package!)
+ (set! index:gc-wabbit-descwiptor
+ (fixed-objects-vector-slot 'GC-WABBIT-DESCWIPTOR))
+ (install))
+
+
+(define (wabbit-hunt wabbit-descwiptor #!optional fudd-thunk)
+ "(WABBIT-DESCWIPTOR #!optional FUDD-THUNK)
+
+ Procedure behavior:
+ ------------------
+
+ Open wabbit season on wabbits matching WABBIT-DESCWIPTOR and go wabbit
+ hunting. Once all the wabbits have been wounded up, invoke FUDD-THUNK,
+ weturning the wesult of FUDD-THUNK as the wesult of the wabbit hunt.
+
+ The optional FUDD-THUNK pawameter defaults to the value of the fluid
+ vawiable: *DEFAULT-FUDD-THUNK*, which defaults to just weturning the
+ wabbit buffer (which will have been swabbed upon return!).
+
+ Explanation of parameters:
+ -------------------------
+
+ A ``wabbit descwiptor'' is a 4-element vector:
+ ------------------------------------------------------------------------
+ 0. Boolean hunt disable flag -- (a.k.a. ``duck season'' flag)
+ avoid wabbit hunting and/or headhunting
+ upon the next GC flip.
+
+ 1. Wabbit vector -- vector of object references to target objects
+ (a.k.a. ``wabbits'')
+
+ 2. Wabbit buffer -- vector into which wabbit sightings are recorded.
+ This must be of length (2 + twice wabbit vect len).
+
+ 3. Boolean headhunt enable flag -- if FALSE, no headhunt is performed.
+ else this slot will be replaced by a
+ headhunt collection upon completion
+ of the headhunting wabbit hunt.
+ ------------------------------------------------------------------------
+ ****
+ NB a) Both the WABBIT-VECTOR and the WABBIT-BUFFER must reside in the heap
+ **** i.e., they may *not* reside in constant space or on the stack.
+ b) Both the wabbit buffer and the headhunt collection slots are zeroed
+ upon return, since they may contain unsafe pointers. Moreover, it
+ is unsafe for the FUDD-THUNK to return them or otherwise close over
+ them. Consider them only to be very fluid parameter sources for the
+ FUDD-THUNK.
+
+ The ``wabbit buffer'' should be a vector of FALSEs before the wabbit hunting
+ is initiated. At the end of the wabbit hunt, the wabbit buffer contents will
+ be laid out as follows:
+ --------------------------------------------------------------------------
+ slot 0 = Boolean flag: TRUE if all wabbit sightings were recorded in the
+ wabbit buffer
+ FALSE if the wabbit buffer was too small to accomo-
+ date a record for each wabbit sighting.
+ (In this case, the FUDD-THUNK should do a
+ bit of cleanup work so the same wabbit
+ hunt can be re-initiated later.)
+ slot 1 = Fixnum: number of wabbit sightings recorded in the wabbit buffer
+ slot 2 = Object reference: cite of first wabbit sighting (``wabbit hole'')
+ slot 3 = Number: offset into first sighting object where wabbit is hiding
+ --------------------------------------------------------------------------
+ ...and so on, with even-index slots containing wabbit holes and odd-index
+ slots, indices. Note that slot 1 should hold the index of the first even
+ slot that holds FALSE and all slots thereafter should likewise hold FALSE.
+\f
+ A ``wabbit hole'' is normally a headed object reference (a pointer) but it
+ may in very rare circumstances be a ``wascally wabbit hole''. There are only
+ three kinds of wascally wabbit holes:
+ ---------------------------------------------------------------------------
+ 1. Characters: these indicate references to wabbit holes in constant space.
+ To reify the character into a cell whose contents holds the
+ wabbit, apply CELLIFY to the slot ref that holds the char.
+ (NB: the char as printed holds only part of the addr; you
+ must vector-ref into the wabbit buffer to get all the
+ addr bits. This is incredible magic.)
+ 2. Null Refs: these indicate headless objects. They should never appear.
+ 3. Stack Refs: these indicate objects on the control stack. Since we reify
+ the stack into the heap as part of the call to WABBIT-HUNT,
+ these too should never appear unless you are doing something
+ painfully obscure (and dangerous!).
+
+ If you ever encounter Null or Stack wabbit holes, you may want to send a
+ friendly bug report (?) to bug-cscheme@zurich.ai.mit.edu with a repeatable
+ test script.
+ ---------------------------------------------------------------------------
+
+ The ``headhunt collection'' is a vector of arbitrary (fixnum) length. It is
+ intended to contain a pointer to the head of every object in the heap which
+ has an object header (spec., numbers, Booleans, etc not included). If all
+ headed heap objects fit in the space available after the GC flip, then slot
+ 0 of this headhunt collection is TRUE. If not, slot 0 is FALSE and the vec-
+ tor contains as many object head references as actually did fit.
+
+ ************ Be verwy verwy careful when headhunting... if you are not careful
+ ** CAVEAT ** to release the headhunt collection (e.g., SET! it to FALSE) or if
+ ************ you gobble up too much intermediate state in traversing it, you
+ will exhaust the available heap space and go down in flames. This
+ is a very fragile system memory feature intended for only the
+ most ginger-fingered discriminating systems wizards. For instance
+ it may some day lead to a post-GC garbage scavenger. Nonetheless,
+ it readily lends itself to self abuse if not treated reverently.
+ "
+\f
+ (cond ((or (default-object? fudd-thunk)
+ (not fudd-thunk))
+ (set! fudd-thunk
+ *default-fudd-thunk*)))
+ (let (;;
+ ;; Uhm... force stack refs into heap during wabbit season; undo at exit
+ ;; and should be careful not to hunt wabbits out of season
+ ;;
+ (call-within-wabbit-season-with-duck-season-return-continuation
+ call-with-current-continuation)
+ ;;
+ ;; gc-flip is the raw low-level wabbit hunt mechanism... the hunt flag
+ ;; enabled in the wabbit-descwiptor forces an alternative
+ ;; ucode gc-loop which goes a-huntin' varmits.
+ (%waw-wabbit-hunt gc-flip)
+ )
+ (wabbit-season! wabbit-descwiptor)
+ (call-within-wabbit-season-with-duck-season-return-continuation
+ (lambda (return-to-duck-season)
+ (%waw-wabbit-hunt)
+ (let ((killed-da-wittle-bunny-wabbits
+ (dynamic-wind
+ (lambda () 'unwind-protect)
+ fudd-thunk
+ ;;
+ ;; Make sure unsafe buffers are cleared before returning...
+ ;;
+ (lambda () (%swab-wad wabbit-descwiptor)))))
+ (return-to-duck-season killed-da-wittle-bunny-wabbits))))))
+
+
+(define *default-fudd-thunk*) ; See install below
+(define (default-fudd-thunk)
+ (wabbit-descwiptor/wabbit-buffer (get-wabbit-descwiptor)))
+
+
+(define-integrable (%swab-wad wad) ; swab the wabbit descwiptor but good
+ ;;
+ ;; Nullify wabbit buffer, leaving found-all-flag and first-null-index intact
+ ;;
+ (let ((wabbit-buffer (wabbit-descwiptor/wabbit-buffer wad)))
+ (cond ((vector? wabbit-buffer)
+ (let ((buflen (vector-length wabbit-buffer)))
+ (subvector-fill! wabbit-buffer
+ (min 2 buflen) ; fuddge
+ buflen
+ false)))))
+ ;;
+ ;; Drop headhunt collection by replacing it w/ the length of the collection,
+ ;; negated if not a complete headhunt collection.
+ ;;
+ (let ((headhunt-coll (wabbit-descwiptor/headhunt-collection wad)))
+ (cond ((vector? headhunt-coll)
+ (let ((head-len (vector-length headhunt-coll))
+ (complete? (vector-ref headhunt-coll 0)))
+ (set-wabbit-descwiptor/headhunt-collection! wad
+ (if complete?
+ head-len
+ (- head-len)))))))
+ unspecific)
+\f
+;; Wabbit Season and Duck Season
+
+(define (wabbit-season! wabbit-descwiptor)
+ "(WABBIT-DESCWIPTOR)
+ Declare open season on wabbits matching our target descwiptor.
+ Returns the old wabbit descwiptor (possibly FALSE).
+ "
+ (%stuff-gc-wabbit-descwiptor! wabbit-descwiptor))
+
+(define (duck-season!)
+ "()
+ Disable wabbit hunting... returns descwiptor from latest wabbit hunt.
+ "
+ (let ((current-wd (get-wabbit-descwiptor)))
+ (cond ((wabbit-descwiptor? current-wd)
+ (set-wabbit-descwiptor/hunt-disable-flag! current-wd true)
+ current-wd)
+ (else
+ (%stuff-gc-wabbit-descwiptor! false)))))
+
+;; Misc
+
+(define (duck-season?)
+ (let ((current-wd (get-wabbit-descwiptor)))
+ (or (false? current-wd)
+ (not (wabbit-descwiptor? current-wd)) ; should not arise, but guard
+ (wabbit-descwiptor/hunt-disable-flag current-wd))))
+
+(define (wabbit-season?)
+ (not (duck-season?)))
+
+
+;; Low-level bits
+
+(define index:gc-wabbit-descwiptor) ; See initialize-package! above
+
+(define-integrable (get-wabbit-descwiptor)
+ (vector-ref (get-fixed-objects-vector) index:gc-wabbit-descwiptor))
+
+(define-integrable (%stuff-gc-wabbit-descwiptor! value)
+ (let* ((fov (get-fixed-objects-vector))
+ (old (vector-ref fov index:gc-wabbit-descwiptor)))
+ (vector-set! fov index:gc-wabbit-descwiptor value)
+ old))
+
+
+;; Very precarious indeed!
+
+(define (cellify object)
+ ((ucode-primitive primitive-object-set-type 2) (ucode-type cell)
+ object))
+\f
+;;;
+;;; Wabbit descwiptor data abstraction-- NB: 4-elt vector rep (ucode depend'cy)
+;;;
+
+(define-integrable (wabbit-descwiptor? object)
+ (and (vector? object) (fix:= (vector-length object) 4)))
+
+(define-structure
+ ( wabbit-descwiptor
+ (conc-name wabbit-descwiptor/)
+ ;;(name 'wabbit-descriptor) ;; unnamed [i.e., not tagged]
+ (type vector))
+ (hunt-disable-flag true READ-ONLY false TYPE boolean)
+ (wabbit-vector (vector) READ-ONLY false TYPE vector)
+ (wabbit-buffer (vector false 2) READ-ONLY false TYPE vector)
+ (headhunt-enable-flag false READ-ONLY false TYPE boolean)
+ )
+
+;; Structure accessor aliases...
+
+;; after the hunt, the flag is replaced by a headhunt collection
+
+(define-integrable
+ (wabbit-descwiptor/headhunt-collection wabbit-descwiptor)
+ (wabbit-descwiptor/headhunt-enable-flag wabbit-descwiptor))
+
+(define-integrable
+ (set-wabbit-descwiptor/headhunt-collection! wabbit-descwiptor new-value)
+ (set-wabbit-descwiptor/headhunt-enable-flag! wabbit-descwiptor new-value))
+\f
+;;;
+;;; Headhunting frobbery... special case of wabbit hunting: no wascally wabbits
+;;;
+
+(define (headhunt #!optional headhunt-fudd-thunk headhunt-wabbit-descwiptor)
+ (cond ((or (default-object? headhunt-fudd-thunk)
+ (not headhunt-fudd-thunk))
+ (set! headhunt-fudd-thunk
+ *default-headhunt-fudd-thunk*))
+ )
+ (cond ((or (default-object? headhunt-wabbit-descwiptor)
+ (not headhunt-wabbit-descwiptor))
+ (set! headhunt-wabbit-descwiptor
+ *default-headhunt-wabbit-descwiptor*))
+ )
+ (wabbit-hunt headhunt-wabbit-descwiptor
+ headhunt-fudd-thunk))
+
+
+(define *default-headhunt-fudd-thunk*) ; See install below
+(define (default-headhunt-fudd-thunk)
+ ;; ,
+ ;; Tres unsafe raven... lets headhunt collection escape the headhunt!
+ ;;
+ (wabbit-descwiptor/headhunt-collection (get-wabbit-descwiptor)))
+
+(define *default-headhunt-wabbit-descwiptor*) ; See install below
+(define (default-headhunt-wabbit-descwiptor)
+ (make-wabbit-descwiptor false ; hunt disable flag disabled
+ (vector) ; wabbit descwiptor null
+ (vector '? 'N) ; wabbit buffer null-ish
+ true ; headhunt enable flag enabled
+ ))
+
+
+
+;;; fini
+
+(define (install)
+ (set! *default-fudd-thunk*
+ default-fudd-thunk)
+ (set! *default-headhunt-fudd-thunk*
+ default-headhunt-fudd-thunk)
+ (set! *default-headhunt-wabbit-descwiptor*
+ (default-headhunt-wabbit-descwiptor))
+ )
+\f
+;;;
+;;; Sample usage (and mis-usage)
+;;;
+
+;; handy util for debuggery
+;;
+;;(define memory-ref (make-primitive-procedure 'primitive-object-ref))
+
+
+#| Sample wreckless wabbit hunt... (does not swab the wabbit buffer)
+ --------------------------------
+(define foobarbaz (cons 'a 'b))
+
+(begin
+ (wabbit-season!
+ (make-wabbit-descwiptor false ; hunt disable flag disabled
+ (vector foobarbaz) ; wabbit vector
+ (make-vector 10 #f) ; wabbit buffer
+ false ; headhunt enable flag disabled
+ ))
+ 'be-careful!)
+
+(gc-flip)
+
+(define done (duck-season!))
+
+(pp done) ; lookin' for trouble
+
+;returns: #(#t #((a . b)) #(#t 4 (foobarbaz a . b) 1 () () () () () ()) ())
+|#
+
+
+#| Sample non-wreckless wabbit hunt... (safe wabbit hole count)
+ ------------------------------------
+(wabbit-hunt
+ (make-wabbit-descwiptor false ; hunt disable flag disabled
+ (vector foobarbaz) ; wabbit vector
+ (make-vector 10 #f) ; wabbit buffer
+ false ; headhunt enable flag disabled
+ ))
+
+; evaluated repeatedly... (stable wabbit hole count... holes swabbed upon exit)
+;
+;Value 31: #(#t 6 () () () () () () () ()) ; - 6 = wabbit hole count + 2
+;Value 32: #(#t 6 () () () () () () () ())
+;Value 33: #(#t 6 () () () () () () () ())
+|#
+\f
+#| Sample dangerous wabbit hunt... (fudd thunk exposes the wabbit holes...hash)
+ -----------------------------
+(wabbit-hunt
+ (make-wabbit-descwiptor false ; hunt disable flag disabled
+ (vector foobarbaz) ; wabbit vector
+ (make-vector 10 #f) ; wabbit buffer
+ false ; headhunt enable flag disabled
+ )
+ (named-lambda (exposing-fudd-thunk)
+ (let* ((wabbuf (wabbit-descwiptor/wabbit-buffer (get-wabbit-descwiptor)))
+ (got-em-all? (vector-ref wabbuf 0))
+ (last-hole-index (vector-ref wabbuf 1)))
+ (display "\n; #(")
+ (do ((index 2 (1+ index)))
+ ((>= index last-hole-index)
+ (if got-em-all?
+ (display ")\n; Th-th-th-that's all folks!")
+ (display ")\n; And many more.... maybe?!?"))
+ (newline))
+ (write (vector-ref wabbuf index)) ; DANGER! WRITE hashes output.
+ (write-char #\Space)))))
+
+; evaluated repeatedly... (stable display)
+
+; #((foobarbaz a . b) 1 #((a . b)) 1 )
+; Th-th-th-that's all folks!
+;No value
+
+; #((foobarbaz a . b) 1 #((a . b)) 1 )
+; Th-th-th-that's all folks!
+;No value
+
+; #((foobarbaz a . b) 1 #((a . b)) 1 )
+; Th-th-th-that's all folks!
+;No value
+
+; #((foobarbaz a . b) 1 #((a . b)) 1 )
+; Th-th-th-that's all folks!
+;No value
+|#
+
+#| Sample semi-wreckless headhunt... (default headhunt-fudd-thunk exposes coll)
+ -------------------------------
+
+(begin (headhunt)
+ (wabbit-descwiptor/headhunt-enable-flag (get-wabbit-descwiptor)))
+
+; evaluated repeatedly... (stable head count... if negative, partial count)
+;
+;Value: 23648
+;Value: 23648
+;Value: 23648
+|#
projects / mit-scheme.git / commitdiff