From: Michael R. Blair Date: Tue, 11 Jul 1995 00:27:56 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~6193 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d1940dd9857b9267f5d62b901a2b63fa8c3bea99;p=mit-scheme.git Initial revision --- diff --git a/v7/src/wabbit/wabbit.scm b/v7/src/wabbit/wabbit.scm new file mode 100644 index 000000000..6ef17e985 --- /dev/null +++ b/v7/src/wabbit/wabbit.scm @@ -0,0 +1,442 @@ +#| -*- 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; 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. + + 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. + " + + (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) + +;; 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)) + +;;; +;;; 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)) + +;;; +;;; 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)) + ) + +;;; +;;; 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 () () () () () () () ()) +|# + +#| 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 +|#