From: Michael R. Blair <edu/mit/csail/zurich/ziggy>
Date: Fri, 14 Jul 1995 04:04:42 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~6174
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3155e97c465f372567c362c3438066c91bfa254a;p=mit-scheme.git
Initial revision
---
diff --git a/v7/src/wabbit/test-wabbit.scm b/v7/src/wabbit/test-wabbit.scm
new file mode 100644
index 000000000..335c583c4
--- /dev/null
+++ b/v7/src/wabbit/test-wabbit.scm
@@ -0,0 +1,335 @@
+;;; -*- Scheme -*-
+
+(DECLARE (USUAL-INTEGRATIONS)) ; MIT Scheme-ism: promise not to redefine prims
+
+;;; $Id: test-wabbit.scm,v 1.1 1995/07/14 04:04:42 ziggy Exp $
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ;;
+;; TEST-WABBIT -- Harey test of wabbit hunting / headhunting g.c. ;;
+;; ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|
+ | |
+ | Uses: |
+ | tons o' stuff not yet documented as dependencies |
+ | |
+ |#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|
+
+;; TODO:
+;;
+;; - Document dependencies
+;; - [SCREWS] see last page
+
+;;; $Id: test-wabbit.scm,v 1.1 1995/07/14 04:04:42 ziggy Exp $
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ;;
+;; TEST-WABBIT -- Harey test of wabbit hunting / headhunting g.c. ;;
+;; ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define *muobj-wabbit-vector* '--TBA--)
+
+(define (muobj-wabbit-vector/install!)
+
+ (define muobj-pair (cons make-unique-object
+ (make-unique-object)))
+ (define muobj-vector (vector 'make 'nique 'bject
+ make-unique-object))
+#|
+ (define muobj-promise (delay make-unique-object))
+|#
+
+ (define-structure (muos (conc-name muos/)
+ (constructor make-muos ()))
+ ( uobj-slot (make-unique-object))
+ ( cuobj-slot (make-unique-object) read-only #T)
+ ( muobj-slot make-unique-object)
+ (cmuobj-slot make-unique-object read-only #T))
+
+ (define muobj-struct1 (make-muos))
+ (define muobj-struct2 (make-muos))
+
+ (define muobj-cell (make-cell make-unique-object))
+ (define muobj-weak-pair (weak-cons (make-unique-object)
+ make-unique-object ))
+
+ (define muobj-weak-car (weak-car muobj-weak-pair)) ; made UObj
+ (define muobj-weak-cdr (weak-cdr muobj-weak-pair)) ; make-UObj
+
+ (define muobj-apply-hook (make-apply-hook muobj-weak-car
+ make-unique-object))
+ (define muobj-entity (make-entity muobj-weak-car
+ make-unique-object))
+ (define muobj-forced-promise (let ((p (delay make-unique-object)))
+ (force p)
+ p))
+
+ (define muobj-wabbit-vector
+ `#(
+ ,muobj-weak-car ; Made UObj
+ ,muobj-weak-cdr ; Make-UObj
+
+ ,muobj-pair
+ ,muobj-vector
+#|
+ ,muobj-promise
+|#
+ ;;
+ ;; (define-structure (muos (conc-name muos/)
+ ;; (constructor make-muos ()))
+ ;; (muobj-slot (make-unique-object))
+ ;; (cmuobj-slot (make-unique-object) read-only true)
+ ;; (muos-slot make-unique-object)
+ ;; (cmuso-slot make-unique-object read-only true))
+ ;;
+ ,muobj-struct1
+ ,muobj-struct2
+
+ ,muobj-cell
+ ,muobj-weak-pair
+ ,muobj-forced-promise
+ ,muobj-apply-hook
+ ,muobj-entity
+ ))
+
+ (set! *muobj-wabbit-vector* muobj-wabbit-vector)
+
+ (pp (cons 42 make-unique-object)) ; Random un-named pair for pp hashing
+
+ 'DONE)
+
+(define (forced-promise? x) (and (promise? x) (promise-forced? x)))
+
+(define (muobj-wabbit-hunt)
+ (wabbit-hunt
+ (make-wabbit-descwiptor false ; hunt disable flag disabled
+ *muobj-wabbit-vector* ; targets of the hunt
+ (make-vector 100 #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))
+
+ (let ((next-elt (vector-ref wabbuf index)))
+ (if (odd? index)
+ (write next-elt) ; write index of non-skipped elt
+ (let ()
+ (define (space-write-and-skip! object)
+ (space-out!) (write object) (skip!))
+ (define (space-in-write! object)
+ (space-in!) (write object) )
+ (define (space-out!)
+ (write-char #\Space) (write-char #\=) (write-char #\Space))
+ (define (space-in!)
+ (write-char #\Space) (write-char #\-) (write-char #\Space))
+ (define (skip!) (set! index (1+ index)))
+ (define (offset) (vector-ref wabbuf (1+ index)))
+
+ (write-char #\[) (write index) (write-char #\])
+ (write-char #\Space)
+ (write (microcode-type-name next-elt))
+
+ (cond ((pair? next-elt)
+ (space-write-and-skip! (if (zero? (offset))
+ (car next-elt)
+ (cdr next-elt))))
+ ((vector? next-elt)
+ (space-write-and-skip! (vector-ref next-elt
+ (-1+ (offset)))))
+ ((record? next-elt)
+ (space-write-and-skip! (%record-ref next-elt
+ (-1+ (offset)))))
+ ;;
+ ;; MIT Scheme specific extensions...
+ ;;
+ ((cell? next-elt)
+ (space-write-and-skip! (cell-contents next-elt)))
+ ((weak-pair? next-elt)
+ (space-write-and-skip! (if (zero? (offset))
+ (weak-car next-elt)
+ (weak-cdr next-elt))))
+ ((forced-promise? next-elt)
+ (space-write-and-skip! (force next-elt)))
+ ((promise? next-elt) ; Must follow forced-promise
+ (space-write-and-skip! next-elt ))
+ ((%entity-extra/apply-hook? next-elt)
+ (space-write-and-skip! (case (offset)
+ ((0) (system-hunk3-cxr0 next-elt))
+ ((1) (system-hunk3-cxr1 next-elt))
+ ((2) (system-hunk3-cxr2 next-elt)))))
+ ((apply-hook? next-elt) ; SIGH: hunk3/triple hack uproc
+ (space-write-and-skip! (if (zero? (offset))
+ (apply-hook-procedure next-elt)
+ (apply-hook-extra next-elt))))
+ ((entity? next-elt)
+ (space-write-and-skip! (if (zero? (offset))
+ (entity-procedure next-elt)
+ (entity-extra next-elt))))
+ ((environment? next-elt)
+ (space-write-and-skip! (system-vector-ref next-elt
+ (-1+ (offset)))))
+ ((and (compiled-code-block? next-elt)
+ (compiled-code-block/manifest-closure? next-elt))
+ (space-write-and-skip! (system-vector-ref next-elt
+ (-1+ (offset)))))
+ ;;
+ ;; Normal compiled code blocks are unsafe since may ref
+ ;; into the R/W/X cache of the linkage section.
+ (else
+ (space-in-write! next-elt))))))
+ ;(display "\n; #(") ; From above
+ (display "\n; ")))))
+ )
+
+(define (test-wabbit-go-for-it)
+ (muobj-wabbit-vector/install!)
+ (muobj-wabbit-hunt)
+ )
+
+#| Until somebody builds the newest Scheme band...
+
+(define %entity-extra/apply-hook?
+ (access %entity-extra/apply-hook? (->environment '(runtime procedure))))
+|#
+
+(let-syntax ((ucode-type (macro (name) (microcode-type name))))
+
+ (define apply-hook-tag
+ (access apply-hook-tag (->environment '(runtime procedure))))
+
+ (define (%entity-extra/apply-hook? extra)
+ ;; Ziggy cares about this one.
+ (and (object-type? (ucode-type hunk3) extra)
+ (eq? apply-hook-tag (system-hunk3-cxr0 extra))))
+ )
+
+
+
+;;; fini
+
+(provide "Test Wabbit")
+
+;;; Complete dependencies (desire = run-time require (not load-time require))
+
+(begin
+
+ (with-working-directory-pathname "Utils/"
+ (named-lambda (acknowledge-Utils-desiderata)
+ (desire "Unique Objects" "unique-objects")
+ ))
+
+ (load-option 'wabbit )
+ (load-option 'pc-sample)
+
+ (with-working-directory-pathname "../ObjectType/"
+ (named-lambda (acknowledge-ObjType-desiderata)
+ (desire "Object Structural Types" "objtype")
+ ))
+ )
+
+#| Example run...
+
+;; First time...
+(test-wabbit-go-for-it)
+
+;; Thereafter...
+(muobj-wabbit-hunt)
+
+(42 . #[compiled-closure 31 ("unique-objects") #xD0 #x7B6D24 #x79276C])
+
+|#
+
+; #([2] pair = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [4] vector = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [6] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [8] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [10] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [12] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [14] cell = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [16] weak-cons = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [18] promise = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [20] entity = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
+; [22] entity = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [24] compiled-code-block = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
+; [26] triple = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
+; [28] triple = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [30] compiled-code-block - #[compiled-code-block 33]
+; 602
+; [32] quad - #[quad 34]
+; 0
+; [34] weak-cons = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+; [36] weak-cons = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
+; )
+; Th-th-th-that's all folks!
+;No value
+
+
+(begin
+ (load "/scheme/700/compiler/etc/disload")
+ (load-disassembler))
+
+#|
+(compiler:disassemble #@33)
+
+Disassembly of #[compiled-code-block 33] (Block 2 in /sw/ziggy/Projects/Descartes/Wabbit/test-wabbit.inf):
+Code:
+
+14DFD24 8 (ble () (offset 0 4 3))
+14DFD28 C (ldi () #x1A #x1C)
+14DFD2C 10 (external-label () #x101 (@pco #x14))
+14DFD30 14 (combf (<) #x15 #x14 (@pco #x-14))
+.
+.
+.
+
+Constants:
+
+14E0608 8EC #[LINKAGE-SECTION #x21]
+14E060C 8F0 2 argument procedure cache to #[compiled-entry 35 () #xC #x1501DF0]
+14E0618 8FC 2 argument procedure cache to #[compiled-entry 36 () #xC #x1501E10]
+14E0624 908 3 argument procedure cache to #[compiled-procedure 37 ("uproc" #x1D) #x14 #x392160]
+14E0630 914 3 argument procedure cache to #[compiled-procedure 38 ("uproc" #x24) #x14 #x3923D0]
+14E063C 920 2 argument procedure cache to #[compiled-procedure 39 ("list" #x14) #x14 #x394808]
+14E0648 92C 3 argument procedure cache to #[compiled-procedure 40 ("list" #xF) #x14 #x3945B0]
+14E0654 938 2 argument procedure cache to #[compiled-procedure 41 ("list" #x12) #x14 #x3946E8]
+14E0660 944 2 argument procedure cache to #[compiled-entry 42 () #xC #x1501E28]
+14E066C 950 3 argument procedure cache to #[compiled-entry 43 () #xC #x1501E40]
+14E0678 95C 5 argument procedure cache to #[compiled-entry 44 () #xC #x1501E58]
+14E0684 968 1 argument procedure cache to #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
+14E0690 974 #[LINKAGE-SECTION #x10001]
+14E0694 978 Reference cache to make-unique-object
+14E0698 97C #[LINKAGE-SECTION #x20001]
+14E069C 980 Assignment cache to *muobj-wabbit-vector*
+14E06A0 984 #[LINKAGE-SECTION #x30003]
+14E06A4 988 3 argument procedure cache to #[compiled-entry 45 () #xC #x1501E78]
+14E06B0 994 done
+14E06B4 998 "muos"
+14E06B8 99C (uobj-slot cuobj-slot muobj-slot cmuobj-slot)
+14E06BC 9A0 make
+14E06C0 9A4 nique
+14E06C4 9A8 bject
+14E06C8 9AC (#[dbg-info 46] "/sw/ziggy/Projects/Descartes/Wabbit/wabbit-
+14E06CC 9B0 #[environment 47]
+
+;No value
+|#
+
+;;
+;; [SCREWS]: Environments (system-vector-ref (-1+ index))
+;; Compiled code blocks -- appear in linkage section. Indir thru env.
+;; Quads - what a ref trap points to in a linkage section.
+;; ...don't sweat it... will lexical-assign w/in env.
+;; Quotations [scode.scm --- %singleton-set-car!]
+;;