'From Squeak3.8gamma of ''24 November 2004'' [latest update: #6548] on 31 March 2005 at 11:00:30 am'!
"Change Set:		System-Tracing
Date:			19 October 2004
Author:			Anthony Hannan, Stephen Pair, Dan Ingalls

This changeSet defines SystemTracer2 (ajh), a more flexible and reliable SystemTracer.  It also includes RehashingSystemTracer (svp) which allows changing identityHashes and SystemTracer64 (di) which will write 64-bit images.  If you find tracing to be unduly slow, locate and fileIn NoAssocDict-ajh for faster dictionary management."!

Stream subclass: #PositionableStream
	instanceVariableNames: 'collection position readLimit '
	classVariableNames: 'IntBuffer '
	poolDictionaries: ''
	category: 'Collections-Streams'!
Object subclass: #SystemTracer2
	instanceVariableNames: 'swapMap oopMap traceQueue byteStream nextChunk displayBox nilOop wordSize'
	classVariableNames: 'LargeIdentityDict'
	poolDictionaries: ''
	category: 'System-Tracing'!

!SystemTracer2 commentStamp: '<historical>' prior: 0!
This is a rewrite of SystemTracer.  It makes it easier to convert images, although it requires more space.

Use it by subclassing it and overriding desired methods in:
	'object relacement' to create replacement objects for desired objects (swapMap);
	'object encoding' to specify bit representation of objects;
	'clone startup' to initialize the new image on first startup.

The default is to trace and write the system in V3 image format.

To run the tracer do "YourTracerSubclass writeImage: 'newImageFile.image'".  The .changes file will be copied as well.  The tracer requires a lot of space to run since it is keeps an oopMap for every object in the system, and a swapMap for every object replacement.  And because these maps are very large and Squeak has a poor identityHash function, the tracer runs slowly.


Structure:

 swapMap	IdentityDictionary (oldObject -> newObject)
			When an object is visited, swapMap is checked to see if it has a replacement, and if so the new object is traced and written instead of the original.  You can add to the swapMap in initSwapMapPreShutdown or initSwapMapPostShutdown before tracing starts, or you can add to it during tracing in convert:pointer:field:.  The tracer automatically adds itself and the active process to swapMap so it own execution won't be traced (pvtWriteImageConverted).

 oopMap	IdentityDictionary (object -> oop)
			Maps objects to their new oops.  The tracer checks this in case a visited object has already been reached.

 traceQueue  OrderedCollection (object)
			Queue of objects that have been reached by the tracer and assigned a new oop, but have not yet been written and traced themselves.  The image is traced by adding specialObjectArray to the queue, then repeatedly removing the first object and tracing it until the queue is empty.  An object is traced by adding all its field values (including the class field) that haven't already been reached (oopMap) to the queue.

 byteStream  FileStream
			The target image file that gets written to during tracing.  Oops equal stream positions.

 nextChunk  Integer
			Oop (minus header size) assigned to the next object reached by the tracer.

 displayBox  Rectangle
			Bounds of Squeak window; written in image header.

 nilOop 		Integer
			Oop of new nil object.  Need here since nil can't be added as a key to oopMap dictionary.

Class Vars:

LargeIdentityDict	IdentityDictionary class
					The tracer uses this class for its large maps, so link your favorite large dictionary class to this.
!

SystemTracer2 subclass: #RehashingSystemTracer
	instanceVariableNames: 'lastHash hashMap'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Tracing'!

!RehashingSystemTracer commentStamp: 'svp 8/23/2002 20:28' prior: 0!
I am just like SystemTracer2, except that I write new identity hashes for objects.  I rehash some special sets (like MethodDictionaries) prior to writing the clone image, and the clone image will rehash all objects when it starts up.

My instance variables:

lastHash - the lastHash that was assigned...I use the same algorithm to generate hashes as the VM
hashMap - A dictionary of all assigned identity hashes 

Subclasses can extend me if they need to write new images with modified hash values.!

SystemTracer2 subclass: #SystemTracer64
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Tracing'!

!SystemTracer64 commentStamp: '<historical>' prior: 0!
This variant of SystemTracer will write an image designed to be loaded and run on 64-bit machines.

Note that this version does not do rehashing, in order that it can avoid the huge rehash at startup that takes forever in simulation.  It is intended that you do one write with SystemTracer2, and then an *identical* write with SystemTracer64.  Then you can write execution logs from the 32-bit version and use them to verify the 64-bit version.

This first pass attempts to make minimal changes to the Tracer framework, by simply padding most fields with 0 in the high 32 bits, and sign-extending the small integers.

The object header written is as follows...
	Squeak 3.8									64-bit header
	3 bits	reserved for gc (mark, old, dirty)	same
	12 bits	object hash (for HashSets)			same
	5 bits	compact class index					same
	4 bits	object format						same
	6 bits	object size in 32-bit words			5 bits	object size in 64-bit words
												1 bit	high bit of the 3-bit size residue; the
														low 2 bits are in format as before
	2 bits	header type (0: 3-word, 1: 2-word,	same
						2: forbidden, 3: 1-word)

Note that as of this writing, the change for 64-bit modulus of bitmaps has not yet been made.
While we would never want to live with this header format, it makes only one very local change:
!


!ProtoObject methodsFor: 'system primitives' stamp: 'ajh 7/12/2001 19:58'!
basicSize
	"Primitive. Answer the number of indexable variables in the receiver. 
	This value is the same as the largest legal subscript. Essential. Do not 
	override in any subclass. See Object documentation whatIsAPrimitive."

	<primitive: 62>
	"The number of indexable fields of fixed-length objects is 0"
	^ 0! !

!ProtoObject methodsFor: 'system tracing' stamp: 'ajh 4/3/2004 07:07'!
forSystemTracer: swapMap
	"May want to create a new object and add it to swapMap under self.  Be sure to check that self has not already been added to swapMap, since self may receive this message multiple times if it is referenced by multiple objects.  Return the new object that is to substitute for self, or self is there is no substitute.  It is ok for the substitute to have pointers to objects that still need to be converted.  They will be converted when the substitute is traced by the system tracer.  Alternatively, you can convert them right away by sending forSystemTracer: to them.
	If you know only certain classes will be converted then it may be faster to override this method in subclasses that get converted and make this method just return self, but be sure you don't neglect objects that are added to the swapMap by the tracer itself (see references to swapMap in SystemTracer2)"

	^ swapMap at: self ifAbsent: [self]! !

!ProtoObject methodsFor: 'system tracing' stamp: 'ajh 8/20/2002 23:27'!
forSystemTracer: swapMap pointer: pointer field: index
	"May want to create a new object and add it to swapMap under self.
	 pointer is the object pointing to obj via its field at index.  You may want to convert obj to different objects depending on who is pointing to it.  If this is the case you will want to remember the multiple mappings in swapMap.  You can do this by keeping another map inside the swapMap keyed at a special symbol"

	^ self forSystemTracer: swapMap! !

!ProtoObject methodsFor: '*systemtracer2' stamp: 'svp 8/22/2002 21:45'!
rehashWithoutBecome
	"Do nothing.  Here so sending this to a Set does not have to do a time consuming respondsTo:"

	^self rehash! !


!Object methodsFor: 'testing' stamp: 'di 5/4/2004 18:07'!
isContextPart

	^ false! !


!Behavior methodsFor: 'system tracing' stamp: 'ajh 1/18/2002 20:12'!
indexIfCompactForConversion
	"subclasses may override this to change cc index during conversion.  You must update the compact classes array yourself"

	^ self indexIfCompact! !


!CompiledMethod class methodsFor: 'class initialization' stamp: 'ajh 7/7/2001 16:37'!
fullFrameSize

	^ LargeFrame! !


!ContextPart methodsFor: 'query' stamp: 'di 5/4/2004 17:44'!
isContextPart

	^ true! !


!BlockContext methodsFor: 'private' stamp: 'ajh 7/7/2001 16:44'!
frameSize

	^ home ifNil: [CompiledMethod fullFrameSize] ifNotNil: [self method frameSize]! !


!MethodContext methodsFor: 'private' stamp: 'ajh 7/7/2001 16:44'!
frameSize

	^ method ifNil: [CompiledMethod fullFrameSize] ifNotNil: [self method frameSize]! !


!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'ajh 10/13/2001 15:11'!
nextLongPut: positiveInt
	"Write positiveInt in the next four bytes preserving the current endianess"

	self nextPutAll: (IntBuffer at: 1 put: positiveInt; yourself)
! !


!PositionableStream class methodsFor: 'instance creation' stamp: 'ajh 10/13/2001 15:12'!
initialize

	IntBuffer _ WordArray new: 1.! !


!Set methodsFor: 'private' stamp: 'svp 8/23/2002 09:24'!
compare: element with: object

	^element = object! !

!Set methodsFor: 'private' stamp: 'svp 8/23/2002 09:48'!
findElementOrNil: anObject hash: hash
	"Answer the index of a first slot containing either a nil (indicating an empty slot) or an element that matches the given object. Answer the index of that slot or zero. Fail if neither a match nor an empty slot is found."

	| index |

	index _ self scanFor: anObject hash: hash.
	index > 0 ifTrue: [^index].

	"Bad scene.  Neither have we found a matching element
	nor even an empty slot.  No hashed set is ever supposed to get
	completely full."
	self error: 'There is no free space in this set!!'.! !

!Set methodsFor: 'private' stamp: 'svp 8/23/2002 09:47'!
scanFor: anObject hash: hash
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."

	^self 
		scanFor: anObject 
		startingAt: (hash \\ array size) + 1
! !

!Set methodsFor: 'private' stamp: 'svp 8/23/2002 10:09'!
scanFor: anObject startingAt: start
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element |

	"Search from (hash mod size) to the end."
	start to: array size do:
		[:index | ((element _ array at: index) == nil or: 
			[self compare: element with: anObject])
				ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: 
			[self compare: element with: anObject])
				ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !


!IdentityDictionary methodsFor: '*systemtracer2' stamp: 'ajh 4/3/2004 18:33'!
cloneUsingHashesFrom: tracer

	| object newDict |
	newDict := self shallowCopy.
	newDict withArray: (Array new: array size).
	1 to: array size do:
		[ :i |
		object := array at: i.
		object ifNotNil:
			[newDict
				noCheckAdd: object
				hash: (tracer newHashFor: object key)]].
	^newDict! !

!IdentityDictionary methodsFor: '*systemtracer2' stamp: 'svp 8/23/2002 18:36'!
noCheckAdd: anObject hash: hash
	"Variant to allow the hash to be specified
	by the caller.  8/23/02 svp"

	array at: (self findElementOrNil: anObject key hash: hash) put: anObject.
	tally _ tally + 1! !


!MethodDictionary methodsFor: 'private' stamp: 'svp 8/23/2002 17:32'!
scanFor: anObject startingAt: start
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element |

	"Search from (hash mod size) to the end."
	start to: array size do:
		[:index | ((element _ self basicAt: index) == nil or: 
			[element == anObject])
				ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ self basicAt: index) == nil or: 
			[element == anObject])
				ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!MethodDictionary methodsFor: '*systemtracer2' stamp: 'ajh 4/3/2004 18:33'!
cloneUsingHashesFrom: tracer

	| newDict key |
	newDict := self class basicNew: self basicSize.
	newDict init: array size.
	1 to: self basicSize do: 
		[ :i |
		key := self basicAt: i.
		key ifNotNil: 
			[newDict 
				noCheckAt: key 
				put: (array at: i) 
				hash: (tracer newHashFor: key)]].
	^newDict! !

!MethodDictionary methodsFor: '*systemtracer2' stamp: 'svp 8/23/2002 16:26'!
noCheckAt: key put: value hash: identityHash
	"Set the value at key to be value."
	| index |
	index _ self findElementOrNil: key hash: identityHash.
	(self basicAt: index) == nil
		ifTrue: 
			[tally _ tally + 1.
			self basicAt: index put: key].
	array at: index put: value.
	^ value! !


!String methodsFor: '*systemtracer2' stamp: 'svp 8/22/2002 22:45'!
hashMappedBy: map
	"My hash is independent of my oop."

	"While this statement is technically correct, it is misleading.  My hash does
	depend on the identity hash of my species, therefore it does need special care
	when cloning an image with new identity hashes - svp"

	^String stringHash: self initialHash: (self species hashMappedBy: map)! !


!Symbol methodsFor: '*systemtracer2' stamp: 'svp 11/15/2002 16:14'!
hashMappedBy: map
	"** DELETEME ** Overridden here to work with DVS packaging mechanism."

	^super hashMappedBy: map! !


!SystemDictionary methodsFor: 'sources, change log' stamp: 'ikp 3/26/2005 21:59'!
wordSize
	"Answer the size (in bytes) of an object pointer."
	"Smalltalk wordSize"

	^[SmalltalkImage current vmParameterAt: 27] on: Error do: [4]! !

!SystemDictionary methodsFor: '*systemtracer2' stamp: 'di 5/5/2004 13:59'!
rehashEntireImage
	"Note, we cannot use allObjectsDo: because some objects like to swap identities
	during a rehash...this means that allObjectsDo: will not find all objects.  Also, this
	algorithm delays become operations to the very end where we can do them all at once. -svp"
	"Smalltalk rehashEntireImage"

	| objectCount allObjects numMdicts oldObjs newObjs newObject |

	numMdicts := MethodDictionary allInstances size.
	oldObjs := OrderedCollection new: numMdicts.
	newObjs := OrderedCollection new: numMdicts.

	"Create an array big enough to hold all objects in memory"
	objectCount := 0.
	self systemNavigation allObjectsDo: [ :ea | objectCount := objectCount + 1].
	allObjects := Array new: objectCount + 500.

	"Now fill the array"
	objectCount := 0.
	self systemNavigation allObjectsDo: [ :ea | allObjects at: (objectCount := objectCount + 1) put: ea ].

"Progress bar disabled until proven innocent here..."
	"'Rehashing the image: ', objectCount printString, ' objects' 
		displayProgressAt: Display center
		from: 1 to: objectCount
		during: [:bar | "
			objectCount := 0.
			allObjects do: [ :ea |
				"bar value:" (objectCount := objectCount + 1).
				newObject := ea rehashWithoutBecome.
				(newObject ~~ ea) ifTrue: 
					[oldObjs add: ea.
					newObjs add: newObject].
			].
			oldObjs asArray elementsExchangeIdentityWith: newObjs asArray.
		"]."! !


!SystemTracer2 methodsFor: 'run' stamp: 'di 5/5/2004 14:32'!
writeImage: imageFileName
	"Trace all object in the image and write them out to imageFileName.  See class comment for details."
	"SystemTracer2 writeImage: 'clone.image'"

	| doProcessStartup |

	"Build some of swapMap if desired"
	self initialize: self class numObjects.
	self initSwapMapPreShutdown.
	Smalltalk garbageCollect.

	"Open image file"
	byteStream _ FileStream newFileNamed: imageFileName.
	byteStream binary.

	"Copy changes file"
	(SourceFiles at: 2) ifNotNil:[
		Smalltalk saveChangesInFileNamed: (Smalltalk fullNameForChangesNamed: imageFileName)].

	"DisplayBox needed for image header"
	displayBox _ Display boundingBox.

	"Shutdown extraneous processes (like snapshot) then trace image.
	 If error happen restart extraneous processes so we can debug.
	 In either case, close image file when done.
	 If we proceed from debugger we won't need to startup processes afterwards."
	doProcessStartup _ true.
	[	[	self processShutdown.
			self isolateAndTrace.
			"** New clone image will start up from here **"
		] on: Error do: [:ex |
			self processStartup.
			doProcessStartup _ false.
			ex pass.
		]
	] ensure: [self isStartingClone ifFalse: [byteStream close]].
	"isStartingClone will be true in clone image but false in tracing image"

	"Startup image processes.  If in clone do special startup if desired"
	self isStartingClone ifTrue: [self clonePreStartup].
	doProcessStartup ifTrue: [self processStartup].
	self isStartingClone ifTrue: [self clonePostStartup].
	self isStartingClone ifFalse: [self inform: 'Done tracing!!'].
! !

!SystemTracer2 methodsFor: 'object replacement' stamp: 'ajh 4/3/2004 06:38'!
convert: obj pointer: pointer field: index
	"May want to substitute a new object for obj.  And you may want to substitute diferent objects depending on the pointer.  pointer is the object pointing to obj via its field at index.
	Delegate to obj so it can decide if it wants to convert and how.  Make sure they check the swapMap in case a substitute has already been created for them in initSwapMapPreShutdown or initSwapMapPostShutdown or pvtWriteImageConverted.  Each SystemTracer subclass should probably use a different convert message that looks like 'forSubclassName:...' so each subclass can have its own set of conversion methods.  You can model them after the forSystemTracer:... methods."

	^ obj forSystemTracer: swapMap pointer: pointer field: index! !

!SystemTracer2 methodsFor: 'object replacement' stamp: 'ajh 4/3/2004 04:29'!
initSwapMapPostShutdown
	"Subclasses may want to add converted objects to swap map before starting trace but after shuting down extra processes"
! !

!SystemTracer2 methodsFor: 'object replacement' stamp: 'ajh 4/3/2004 04:32'!
initSwapMapPreShutdown
	"Subclasses may want to add converted objects to swapMap before starting trace and before shuting down extra processes"
! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'di 5/4/2004 14:21'!
compactHeaderSizeMax
	"This is the max number of words (plus 1 for header) for a compact object"

	^ 16r3F! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'ajh 4/3/2004 09:52'!
hashMask

	^ 16rFFF! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'di 5/4/2004 13:07'!
headersFor: class classOop: classOop hash: hash numFields: length
	"Return header words for new object.
	 Three possibilities:
		{length, class, baseHeader}
		{class, baseHeader}
		{baseHeader}"

	| header3 header2 header1 cix sizeFld lowBits |
	"3 gc bits"
	header1 _ 0.  "Mark, old, dirty"

	"Add hash"
	header1 _ header1 bitShift: 12.	"next fld is 12 bits"
	header1 _ header1 + (hash bitAnd: self hashMask).

	"Add compact class index or class header"
	header1 _ header1 bitShift: 5.
	cix _ class indexIfCompactForConversion.	"0 means need full word"
	header2 _ classOop.
	header1 _ header1 + (cix bitAnd: 16r1F).

	"Add object format (with low bits of size)"
	header1 _ header1 bitShift: 4.
	header1 _ header1 + class instSpec.
	class isWords ifFalse:
		[lowBits _ (wordSize-1) - (length + (wordSize-1) bitAnd: (wordSize-1)).
						"For byte objects: size = wordSize - spec.lowBits"
		header1 _ header1 + lowBits].
	"Note code above will generate low bits up to 7 for wordSize = 8,
	but format codes are not prepared to accept this"

	"Add size in long words (includes base header)"
	header1 _ header1 bitShift: 6.
	sizeFld _ (class isBytes ifTrue: [length + (wordSize-1) // wordSize]
						ifFalse: [length]) + 1.
	sizeFld > 16r3F
		ifTrue: [header3 _ sizeFld bitShift: 2.  sizeFld _ 0]
		ifFalse: [header3 _ 0].
	header1 _ header1 + sizeFld.

	header1 _ header1 bitShift: 2.

	header3 > 0 ifTrue: ["3-word: type=0"
		^ WordArray with: header3 + 0 with: header2 + 0 with: header1 + 0].
	cix = 0 ifTrue: [ "2-word: type=1"
		^ WordArray with: header2 + 1 with: header1 + 1].
	"1-word: type=3"
	^ WordArray with: header1 + 3! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'ajh 8/20/2002 19:53'!
identityHashFor: object
	"object is the new object if the original was converted.  If you change the identity hash, you will want to rehash all objects in cloneStartUp.  However, if you change the identity hash of selectors (Symbols), then you should convert MethodDictionaries and selectors up front, before/during tracing"

	^ object identityHash! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'di 6/3/2004 19:34'!
imageHeaderSize

	^ 64  "bytes"
! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'ajh 8/20/2002 16:50'!
integerOopOf: value

	value < 0
		ifTrue: [^ ((16r80000000 + value) << 1) + 1]
		ifFalse: [^ (value << 1) + 1]! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'ajh 4/3/2004 04:26'!
lastHash

	^ Object new identityHash! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'di 5/4/2004 19:30'!
lengthAndHeaderSizeFor: object numFields: n
	"Return instance word length (including base header), and instance header size (including base header).  This method should be consistent with headersFor:classOop:hash:numFields:"

	| cix size class |
	class _ object class.
	class isBits
		ifTrue: [class isBytes "Note literal bloat of CMs has been dealt with by caller"
				ifTrue: [size _ n + (wordSize-1) // wordSize + 1]
				ifFalse: [size _ n + (wordSize//4-1) // (wordSize//4) + 1]]
		ifFalse: [size _ n + 1].	"size in long words, incl hdr0"
		
	cix _ class indexIfCompactForConversion.	"0 means need full word"
	size > self compactHeaderSizeMax ifTrue: [^ {size. 3}].
	cix = 0 ifTrue: [^ {size. 2}].
	^ {size. 1}! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'ikp 9/2/2004 15:34'!
versionNumber
	"Image format version number"

	^6502! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'di 4/7/2004 22:49'!
wordSize
	"# bytes per word -- override for 64-bit images"

	^ 4! !

!SystemTracer2 methodsFor: 'object encoding' stamp: 'di 5/4/2004 15:29'!
wordSizeNowRunning
	"# bytes per word *of this image* -- change if you're running in 64 bits"

	^ 4! !

!SystemTracer2 methodsFor: 'object field enumeration' stamp: 'di 6/14/2004 13:44'!
fixedPlusIndexableSizeFor: object
	"Return my total number of fields"

	(object isContextPart)
		ifTrue: [^ object class instSize + object frameSize].
	object isCompiledMethod
		ifTrue: [^ object basicSize + (self pcDeltaForMethod: object)].
	^ object class instSize + object basicSize! !

!SystemTracer2 methodsFor: 'object field enumeration' stamp: 'di 7/22/2004 10:57'!
object: object allFieldsWithIndex: block collect: sequenceableCollectionClass
	"Evaluate block against each of the pointer fields with index, and collect the results in an instance of sequenceableCollectionClass"

	| fixedSize results varSize nilResults |
	object isCompiledMethod ifTrue:
		[results _ sequenceableCollectionClass new: 1 + object numLiterals.
		1 to: 1 + object numLiterals do:
			[:j | results at: j put: (block value: (object objectAt: j) value: j)].
		^ results].
	
	fixedSize _ object class instSize.
	varSize _ object basicSize.
	results _ sequenceableCollectionClass new: fixedSize + varSize.
	1 to: fixedSize do:
		[:j | results at: j put: (block value: (object instVarAt: j) value: j)].
	1 to: varSize do:
		[:j | results at: fixedSize + j put: (block value: (object basicAt: j) value: fixedSize + j)].

	object isContextPart ifTrue:
		[(object instVarAt: 2) ifNotNil:
			["May need to adjust PC and startPC if changing wordSize..."
			results at: 2 put: (block value: (object instVarAt: 2)+(self pcDeltaForMethod: object method) value: 2)].
		((object isMemberOf: BlockContext) and: [object home notNil]) ifTrue:
				[results at: 5 put: (block value: (object instVarAt: 5)+(self pcDeltaForMethod: object method) value: 5)].
		"Need to fill out the nils beyond the knowable end of stack"
		nilResults _ sequenceableCollectionClass new: object frameSize - object basicSize.
		1 to: nilResults size do:
			[:j | nilResults at: j put: (block value: nil value: j)].
		^ results , nilResults].
	^ results! !

!SystemTracer2 methodsFor: 'object field enumeration' stamp: 'di 6/14/2004 13:43'!
pcDeltaForMethod: method

	^ (wordSize - self wordSizeNowRunning) * (method numLiterals + 1)! !

!SystemTracer2 methodsFor: 'clone startup' stamp: 'ajh 8/22/2002 11:14'!
clonePostStartup
	"This will be executed when the new clone starts up, but after processStartup.  Subclasses may want to open a greeting window or something"! !

!SystemTracer2 methodsFor: 'clone startup' stamp: 'ajh 8/22/2002 11:15'!
clonePreStartup
	"This will be executed right away when the new clone starts up, before processStartup.  Subclasses may want to rehash all objects or something"! !

!SystemTracer2 methodsFor: 'private' stamp: 'di 4/8/2004 00:02'!
initialize: numObjects

	self class initialize.  "To pick up latest large Dictionary class"
	wordSize _ self wordSize.
	swapMap _ LargeIdentityDict new: 4000.
	oopMap _ LargeIdentityDict new: numObjects.
	traceQueue _ OrderedCollection new: numObjects // 4.
! !

!SystemTracer2 methodsFor: 'private' stamp: 'ajh 8/20/2002 16:38'!
isStartingClone
	"byteStream will be nil in new image"

	^ byteStream == nil! !

!SystemTracer2 methodsFor: 'private' stamp: 'di 6/3/2004 19:33'!
isolateAndTrace
	"Make own execution invisible from tracer by putting dummies in swapMap"

	"Map self to empty and thisContext to nil so they don't get traced"
	swapMap at: self put: self class basicNew.
	swapMap at: thisContext put: nil.

	"Make new image start up in sender (writeImageFile:) right after this call.  Push nil since the first instr after the call will be pop"
	thisContext sender push: nil.
	swapMap at: Processor activeProcess put: (Process forContext: thisContext sender priority: Processor activePriority).

	"Trace and write image"
	nextChunk _ self imageHeaderSize.
	'Tracing and writing ', (oopMap capacity * 3//4) printString, ' objects' 
		displayProgressAt: Display center
		from: self imageHeaderSize to: self class imageSize
		during: [:bar |
				self initSwapMapPostShutdown.
				Smalltalk garbageCollect.
				self traceImage: bar].

	"Write header"
	self writeFileHeader.

	"Pop nil that was pushed above for clone image"
	thisContext sender pop.
	^ nil! !

!SystemTracer2 methodsFor: 'private' stamp: 'di 5/4/2004 15:26'!
lengthAndHeaderSizeFor: object
	"Return two sizes in an array:
	 1. object's size in words including my base header,
	 2. my header size in words including base header"

	^ self lengthAndHeaderSizeFor: object numFields: (self fixedPlusIndexableSizeFor: object)! !

!SystemTracer2 methodsFor: 'private' stamp: 'di 6/15/2004 11:41'!
processShutdown

	(Object respondsTo: #flushDependents) ifTrue: [Object flushDependents].
	(Object respondsTo: #flushEvents) ifTrue: [Object flushEvents].
	Smalltalk processShutDownList: false.  "false means not quiting"

	"Note: the next two lines can be omitted when not writing, eg, a 64-bit image,
	but I leave them in so I can debug the 64-bit system against a similar 32.
	They are needed for the 64, lest Forms decompress into old bitmaps."
	Form allInstancesDo: [:f | f unhibernate].
	ColorForm allInstancesDo: [:f | f unhibernate].

	Cursor write show.
! !

!SystemTracer2 methodsFor: 'private' stamp: 'ajh 8/22/2002 11:17'!
processStartup

	Cursor normal show.
	Smalltalk setGCParameters.
	self isStartingClone ifTrue: [Smalltalk clearExternalObjects].
	Smalltalk processStartUpList: self isStartingClone.
	self isStartingClone ifTrue: [
		Smalltalk setPlatformPreferences.
		Smalltalk readDocumentFile].
	Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup].
! !

!SystemTracer2 methodsFor: 'private' stamp: 'di 4/7/2004 23:11'!
reserve: object
	"Add object to write queue and return its oop"

	| lengthAndHeaderSize objectSize hdrSize oop |
	"Calculate oop and reserve space (advance nextChunk)"
	lengthAndHeaderSize _ self lengthAndHeaderSizeFor: object.
	objectSize _ lengthAndHeaderSize at: 1.
	hdrSize _ lengthAndHeaderSize at: 2.
	oop _ nextChunk + ((hdrSize - 1) * wordSize).
	nextChunk _ oop + (objectSize * wordSize).

	"Add object to fill queue and remember its oop"
	oopMap at: object put: oop.
	traceQueue addLast: object.

	^ oop! !

!SystemTracer2 methodsFor: 'private' stamp: 'ajh 8/20/2002 19:24'!
reserve: obj from: pointer field: index
	"Add obj to write queue and return its oop"

	| object |
	obj class = SmallInteger ifTrue: [^ self integerOopOf: obj].

	"Return oop if already visited obj"
	object _ self convert: obj pointer: pointer field: index.
	object ifNil: [^ nilOop].
	oopMap at: object ifPresent: [:itsOop | ^ itsOop].

	^ self reserve: object! !

!SystemTracer2 methodsFor: 'private' stamp: 'di 4/7/2004 23:12'!
traceImage: progressBar
	"Trace image starting with true, false, nil, and specialObjectsArray"

	| lengthAndHeaderSize object oop |

	"Add true and false in front so the VM can assume it will never move (see Interpreter>>interpret)"
	self reserve: true.
	self reserve: false.

	"Need to add nil separately because it can't be added as a key to oopMap"
	lengthAndHeaderSize _ self lengthAndHeaderSizeFor: nil.
	nilOop _ nextChunk + ((lengthAndHeaderSize second - 1) * wordSize).
	nextChunk _ nilOop + (lengthAndHeaderSize first * wordSize).
	self writeAndTrace: nil.

	"Add specialObjectArray next.  Use new array in swap map if present.  This is done explicitly here so swap map does not have to be tested on every Array write"
	object _ swapMap at: Smalltalk specialObjectsArray ifAbsent: [Smalltalk specialObjectsArray].
	lengthAndHeaderSize _ self lengthAndHeaderSizeFor: object.
	oop _ nextChunk + ((lengthAndHeaderSize second - 1) * wordSize).
	nextChunk _ oop + (lengthAndHeaderSize first * wordSize).
	oopMap at: Smalltalk specialObjectsArray put: oop.
	oopMap at: object put: oop.
	self writeAndTrace: object.

	"Write and trace rest of image"
	[traceQueue isEmpty] whileFalse: [
		oop _ self writeAndTrace: traceQueue removeFirst.
		progressBar value: oop
	].
! !

!SystemTracer2 methodsFor: 'private' stamp: 'di 5/4/2004 20:21'!
writeAndTrace: object
	"Write the image representation of me on byteStream at my oop, and add my not-yet-seen fields to traceQueue."

	| lengthAndHeaderSize oop byteSize byteBuffer |
	lengthAndHeaderSize _ self lengthAndHeaderSizeFor: object.
	oop _ oopMap at: object ifAbsent: [object isNil ifTrue: [nilOop] ifFalse: [self halt: 'oop should have been added to oopMap when object was add to traceQueue']].

	"Write header"
	byteStream position: oop - ((lengthAndHeaderSize second - 1) * wordSize).
	byteStream nextPutAll: (self
		headersFor: object class
		classOop: (self reserve: object class from: object field: -1 "class field")
		hash: (self identityHashFor: object)
		numFields: (self fixedPlusIndexableSizeFor: object)
	).

	"Write fields"
	(object class isPointers or: [object class == CompiledMethod]) ifTrue: [
		byteStream nextPutAll: (self object: object
			allFieldsWithIndex: [:val :i | self reserve: val from: object field: i]
			collect: WordArray).
	] ifFalse: [  "isBits"
		byteStream nextPutAll: object.
		object class isBytes
			ifTrue: [  "fill bytes unused in last word"
					1 to: (wordSize-1) - (object basicSize + (wordSize-1)  \\ wordSize)
						do: [:i | byteStream nextPut: 0]]
			ifFalse: [(wordSize = 8 and: [object basicSize odd]) ifTrue:
						[  "fill word unused in last long8"
						byteStream nextPutAll: (WordArray with: 0)]].
	].
	object class == CompiledMethod ifTrue: [
		byteSize _ object basicSize - object initialPC + 1.
		byteBuffer _ ByteArray new: byteSize.
		byteBuffer replaceFrom: 1 to: byteSize with: object startingAt: object initialPC.
		"intermediate ByteArray needed since byteStream (a file) cannot putAll from a subclass of ByteArray (CompiledMethod)"
		byteStream nextPutAll: byteBuffer.
		"fill bytes unused in last word"
		1 to: (wordSize-1) - (byteBuffer size + (wordSize-1)  \\ wordSize)
			do: [:i | byteStream nextPut: 0].
	].

	"Double check that fields take up expected size"
	byteStream position = (oop + (lengthAndHeaderSize first * wordSize)) ifFalse: [
		self error: 'object size discrepency'].

	^ oop! !

!SystemTracer2 methodsFor: 'private' stamp: 'ikp 9/2/2004 15:33'!
writeFileHeader

	| specialObjectsOop |
	specialObjectsOop _ oopMap at: Smalltalk specialObjectsArray.
	byteStream position: 0.
	byteStream nextLongPut: self versionNumber.
	byteStream nextLongPut: self imageHeaderSize.
	byteStream nextLongPut: nextChunk - self imageHeaderSize.
	byteStream nextLongPut: self imageHeaderSize.  "start of memory"
	byteStream nextLongPut: specialObjectsOop.
	byteStream nextLongPut: self lastHash.
	byteStream nextLongPut: displayBox width * 16r10000 + displayBox height.
	byteStream nextLongPut: 0.  "fullScreenFlag"
	byteStream nextLongPut: Smalltalk extraVMMemory.
	byteStream padTo: self imageHeaderSize put: 0.
! !


!RehashingSystemTracer methodsFor: 'rehashing' stamp: 'di 5/5/2004 13:59'!
initSwapMapPostShutdown
	"Subclasses may want to add converted objects to swap map before starting trace but after shuting down extra processes"
	"Note if we pre-hash, eg, IdentityDicts, then this should be called inside the progress bar
	of isolateAndTrace, since it adds morphs to the world"

	| sets elementCount clone |
	sets _ self specialSets.
	elementCount _ sets inject: 0 into: [:c :set | c _ c + set size].
	hashMap := LargeIdentityDict new: elementCount.
	lastHash := 999.
	sets do: [ :ea |
		clone := ea cloneUsingHashesFrom: self.
		swapMap at: ea put: clone].
! !

!RehashingSystemTracer methodsFor: 'rehashing' stamp: 'ajh 4/3/2004 18:36'!
newHashFor: object
	"This is called by cloneUsingHashesFrom: (and compatibility with #hashMappedBy methods?)"

	^ hashMap at: object ifAbsentPut: [self newObjectHash]! !

!RehashingSystemTracer methodsFor: 'rehashing' stamp: 'ajh 4/3/2004 18:39'!
newObjectHash
	"Answer a new pseudo-random number for use as an identity hash."

	lastHash := 13849 + (27181 * lastHash) bitAnd: 65535.
	^ lastHash bitAnd: self hashMask
! !

!RehashingSystemTracer methodsFor: 'rehashing' stamp: 'ajh 4/3/2004 22:07'!
specialSets
	"The sets listed here get rehashed using the newly assigned identity hash values before the clone is written.  On startup, the clone image will rehash all objects to ensure that all hashed structures are properly arranged.  Rehashing is done in this two step process to retain maximum flexibility (if we tried to do everything up front, we would need to update the tracer every time a new type of Set is added with a different hashing and scanning algorithm, plus it would make the hashMap very large and slow)."

	^ MethodDictionary allInstances
! !

!RehashingSystemTracer methodsFor: 'clone startup' stamp: 'svp 8/22/2002 22:01'!
clonePreStartup

	Smalltalk rehashEntireImage! !

!RehashingSystemTracer methodsFor: 'object encoding' stamp: 'ajh 4/3/2004 18:32'!
identityHashFor: object
	"Don not add to hashMap since this is only called once per object"

	^ hashMap at: object ifAbsent: [self newObjectHash]
! !

!RehashingSystemTracer methodsFor: 'object encoding' stamp: 'svp 8/21/2002 12:46'!
lastHash

	^lastHash! !


!SystemTracer2 class methodsFor: 'image' stamp: 'ajh 7/9/2001 19:08'!
imageSize

	^ Smalltalk vmParameterAt: 2! !

!SystemTracer2 class methodsFor: 'image' stamp: 'ajh 7/3/2001 00:53'!
numObjects
	"SystemTracer2 numObjects"

	| count object |
	count _ 0.
	object _ 0 someObject.
	[object == 0] whileFalse: [
		count _ count + 1.
		object _ object nextObject].
	^ count! !

!SystemTracer2 class methodsFor: 'initialize' stamp: 'di 6/3/2004 19:34'!
initialize

	LargeIdentityDict _ Smalltalk at: #LargeIdentityDictionary
		ifAbsent: [Smalltalk at: #NoAssocIdentityDictionary
			ifAbsent: [IdentityDictionary]].
! !

!SystemTracer2 class methodsFor: 'initialize' stamp: 'ajh 4/3/2004 22:01'!
largeDictClass: aIdentityDictionaryClass
	"The tracer will use this class for its large maps"

	LargeIdentityDict _ aIdentityDictionaryClass! !

!SystemTracer2 class methodsFor: 'run' stamp: 'ajh 4/3/2004 08:48'!
writeImage: imageFileName
	"Trace all object in the image and write them out to imageFileName.  See class comment for details."
	"SystemTracer2 writeImage: 'clone.image'"

	^ self new writeImage: imageFileName! !


!SystemTracer64 methodsFor: 'as yet unclassified' stamp: 'di 5/5/2004 00:30'!
alignBitmap: bits forForm: form
	"Check to see that the raster is a multiple of 64 bits.  If so, return bits.
	If not, return a copy extended so that it is."

	| raster padded pStart bStart |
	(raster _ form bitsSize // form height) even ifTrue: [^ bits].
	padded _ Bitmap new: bits size + form height.  "One word of padding per line"
	pStart _ bStart _ 1.
	1 to: form height do:
		[:y |
		padded replaceFrom: pStart to: pStart+raster-1 with: bits startingAt: bStart.
		pStart _ pStart + raster + 1.
		bStart _ bStart + raster].
	^ padded! !

!SystemTracer64 methodsFor: 'as yet unclassified' stamp: 'di 5/4/2004 14:21'!
compactHeaderSizeMax
	"This is the max number of words (plus 1 for header) for a compact object"

	^ 16r1F! !

!SystemTracer64 methodsFor: 'as yet unclassified' stamp: 'di 7/20/2004 14:11'!
headersFor: class classOop: classOop hash: hash numFields: length
	"Return header words for new object."
	 "Three possibilities:
		{length, class, baseHeader}
		{class, baseHeader}
		{baseHeader}"

	| header3 header2 header1 cix sizeFld header32 header64 lowBits lowBits4 lengthInBytes |
	"3 gc bits"
	header1 _ 0.  "Mark, old, dirty"

	"Add hash"
	header1 _ header1 bitShift: 12.	"next fld is 12 bits"
	header1 _ header1 + (hash bitAnd: self hashMask).

	"Add compact class index or class header"
	header1 _ header1 bitShift: 5.
	cix _ class indexIfCompactForConversion.	"0 means need full word"
	header2 _ classOop.
	header1 _ header1 + (cix bitAnd: 16r1F).

	"Add object format (with low bits of size)"
	header1 _ header1 bitShift: 4.
	header1 _ header1 + class instSpec.
	class isPointers
		ifTrue: [lowBits4 _ 0]
		ifFalse:
		[lengthInBytes _ (class isBytes ifTrue: [1] ifFalse: [4]) * length.
		lowBits _ (wordSize-1) - (lengthInBytes + (wordSize-1) bitAnd: (wordSize-1)).
						"For byte objects: size = wordSize - spec.lowBits"
		"Note: lowBits may have the 4 bit on in a 64-bit image.  This bit must
		for now be put in the now-unused bit of the word-size field (see below)."
		lowBits4 _ lowBits bitShift: -2.
		header1 _ header1 + (lowBits bitAnd: 3)].

	"Add size in long words (includes base header)"
	header1 _ header1 bitShift: 6.
	sizeFld _ (class isPointers ifTrue: [length]
						ifFalse: [lengthInBytes + (wordSize-1) // wordSize]) + 1.

	sizeFld _ sizeFld * 2.
	
	sizeFld > 16r3F
		ifTrue: [header3 _ sizeFld bitShift: 2.  sizeFld _ 0]
		ifFalse: [header3 _ 0].

	"Here we stick in the 4's bit of lowBits..."
	header1 _ header1 + sizeFld + lowBits4.

	header1 _ header1 bitShift: 2.

	header3 > 0
		ifTrue: ["3-word: type=0"
				header32 _  WordArray with: header3 + 0 with: header2 + 0 with: header1 + 0]
		ifFalse: [cix = 0
					ifTrue: [ "2-word: type=1"
							header32 _  WordArray with: header2 + 1 with: header1 + 1]
					ifFalse: ["1-word: type=3"
							header32 _  WordArray with: header1 + 3]].

	header64 _ WordArray new: header32 size * 2.
	header32 withIndexDo:
		[:hdrWord :i |
		header64 at: i*2-1 put: 0.  "Zero-fill above 32-bit headers"
		header64 at: i*2 put: hdrWord].
	^ header64! !

!SystemTracer64 methodsFor: 'as yet unclassified' stamp: 'di 6/3/2004 19:32'!
imageHeaderSize
	"64-bit images have twice as big a header"
	
	^ super imageHeaderSize * 2! !

!SystemTracer64 methodsFor: 'as yet unclassified' stamp: 'di 5/5/2004 15:00'!
initSwapMapPostShutdown

	| aligned |
	super initSwapMapPostShutdown.
"
	Forms must be uncompressed first...
	Form allSubInstancesDo:
		[:f | aligned _ self alignBitmap: f bits forForm: f.
		aligned == f bits ifFalse: [swapMap at: f bits put: aligned]]
"! !

!SystemTracer64 methodsFor: 'as yet unclassified' stamp: 'di 4/13/2004 11:59'!
object: object allFieldsWithIndex: fieldAndIndexBlock collect: collectionClass

	| fields32 fields64 fill |
	fields32 _ super object: object allFieldsWithIndex: fieldAndIndexBlock collect: collectionClass.
	fields64 _ collectionClass new: fields32 size * 2.
	fields32 withIndexDo:
		[:field :i |
		field odd
			ifTrue: [(field bitAnd: 16r80000000) = 0
						ifTrue: [fill _ 0]
						ifFalse: [fill _ 16rFFFFFFFF]]  "Sign-extend SmallIntegers"
			ifFalse: [fill _ 0].  "Zero-fill above oops"
		fields64 at: i*2-1 put: fill.
		fields64 at: i*2 put: field].
	^ fields64! !

!SystemTracer64 methodsFor: 'as yet unclassified' stamp: 'ikp 9/2/2004 15:34'!
versionNumber
	"Image format version number"

	^68000! !

!SystemTracer64 methodsFor: 'as yet unclassified' stamp: 'di 4/7/2004 22:58'!
wordSize
	"# bytes per word in target image"

	^ 8! !

!SystemTracer64 methodsFor: 'as yet unclassified' stamp: 'ikp 9/2/2004 15:33'!
writeFileHeader
	"Note here it is assumed that this image is less than 4GB in size.
	Otherwise a few items should be full 8-byte quantities"

	| specialObjectsOop |
	specialObjectsOop _ oopMap at: Smalltalk specialObjectsArray.
	byteStream position: 0.
	byteStream nextLongPut: 0.
	byteStream nextLongPut: self versionNumber.
	byteStream nextLongPut: 0.
	byteStream nextLongPut: self imageHeaderSize.
	byteStream nextLongPut: 0.
	byteStream nextLongPut: nextChunk - self imageHeaderSize.
	byteStream nextLongPut: 0.
	byteStream nextLongPut: self imageHeaderSize.  "start of memory"
	byteStream nextLongPut: 0.
	byteStream nextLongPut: specialObjectsOop.
	byteStream nextLongPut: 0.
	byteStream nextLongPut: self lastHash.
	byteStream nextLongPut: 0.
	byteStream nextLongPut: displayBox width * 16r10000 + displayBox height.
	byteStream nextLongPut: 0.
	byteStream nextLongPut: 0.  "fullScreenFlag"
	byteStream nextLongPut: 0.
	byteStream nextLongPut: Smalltalk extraVMMemory.
	byteStream padTo: self imageHeaderSize put: 0.
! !


!WeakSet methodsFor: 'private' stamp: 'svp 8/23/2002 17:32'!
scanFor: anObject startingAt: start
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements"

	| element |

	"Search from (hash mod size) to the end."
	start to: array size do:
		[:index | ((element _ array at: index) == flag or: 
			[self compare: element with: anObject])
				ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == flag or: 
			[self compare: element with: anObject])
				ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!WeakSet methodsFor: '*systemtracer2' stamp: 'svp 8/23/2002 16:26'!
cloneUsingHashesFrom: tracer

	| newSet object |
	newSet := self class basicNew init: array size.
	1 to: array size do:
		[ :i |
		object := array at: i.
		(object == flag or: [object == nil]) ifFalse:
			[newSet 
				noCheckAdd: object
				hash: (object hashMappedBy: tracer)]].
	^newSet! !

!WeakSet methodsFor: '*systemtracer2' stamp: 'svp 8/23/2002 16:27'!
noCheckAdd: anObject hash: hash
	array at: (self findElementOrNil: anObject hash: hash) put: anObject.
	tally _ tally + 1! !

SystemTracer2 initialize!
PositionableStream initialize!
Stream subclass: #PositionableStream
	instanceVariableNames: 'collection position readLimit'
	classVariableNames: 'IntBuffer'
	poolDictionaries: ''
	category: 'Collections-Streams'!