[Vm-dev] VM Maker: .VMMaker.oscog-eem.615.mcz

[commits at source.squeak.org]

Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/.VMMaker.oscog-eem.615.mcz

==================== Summary ====================

Name: .VMMaker.oscog-eem.615
Author: eem
Time: 12 February 2014, 8:02:02.982 pm
UUID: f518acf8-ff68-42b9-9e4e-aec19abc4d41
Ancestors: VMMaker.oscog-eem.614

Make Spur snapshot avoid writing trailing free space in each
segment to the image file

Fix initialization of primitiveAccessorDepthTable during simulation.

=============== Diff against VMMaker.oscog-eem.614 ===============

Item was changed:
  ----- Method: CCodeGenerator>>shouldIncludeMethodFor:selector: (in category 'utilities') -----
  shouldIncludeMethodFor: aClass selector: selector
  	"process optional methods by interpreting the argument to the option: pragma as either
  	 a Cogit class name or a class variable name or a variable name in VMBasicConstants."
  	(aClass >> selector pragmaAt: #option:) ifNotNil:
  		[:pragma| | key |
  		key := pragma argumentAt: 1.
  		vmMaker ifNotNil:
  			[(Cogit withAllSubclasses anySatisfy: [:c| c name = key]) ifTrue:
  				[| cogitClass optionClass |
  				 cogitClass := Smalltalk classNamed: vmMaker cogitClassName.
  				 optionClass := Smalltalk classNamed: key.
  				 ^cogitClass includesBehavior: optionClass].
+ 			((vmClass
+ 				ifNotNil: [vmClass initializationOptions]
+ 				ifNil: [vmMaker options]) at: key ifAbsent: [false]) ifNotNil:
- 			(vmMaker options at: key ifAbsent: [false]) ifNotNil:
  				[:option| option ~~ false ifTrue: [^true]].
  		(aClass bindingOf: key) ifNotNil:
  			[:binding|
  			binding value ~~ false ifTrue: [^true]].
  		(VMBasicConstants bindingOf: key) ifNotNil:
  			[:binding|
  			binding value ~~ false ifTrue: [^true]]].
  		^false].
  	^true!

Item was added:
+ ----- Method: CogVMSimulator>>codeGeneratorToComputeAccessorDepth (in category 'primitive support') -----
+ codeGeneratorToComputeAccessorDepth
+ 	^VMMaker new
+ 		cogitClass: (Smalltalk classNamed: (self class initializationOptions
+ 												at: #Cogit
+ 												ifAbsent: [self class cogitClass name]));
+ 		buildCodeGeneratorForInterpreter: CoInterpreterPrimitives
+ 		includeAPIMethods: false
+ 		initializeClasses: false!

Item was changed:
  ----- Method: CogVMSimulator>>initialize (in category 'initialization') -----
  initialize
  	"Initialize the CogVMSimulator when running the interpreter inside Smalltalk.  The
  	 primary responsibility of this method is to allocate Smalltalk Arrays for variables
  	 that will be declared as statically-allocated global arrays in the translated code."
  
+ 	transcript := Transcript.
+ 
  	objectMemory ifNil:
  		[objectMemory := self class objectMemoryClass simulatorClass new].
  	cogit ifNil:
  		[cogit := self class cogitClass new setInterpreter: self].
  	objectMemory coInterpreter: self cogit: cogit.
  
  	cogit numRegArgs > 0 ifTrue:
  		[debugStackDepthDictionary := Dictionary new].
  
  	cogThreadManager ifNotNil:
  		[super initialize].
  
  	"Note: we must initialize ConstMinusOne & HasBeenReturnedFromMCPC differently
  	 for simulation, due to the fact that the simulator works only with +ve 32-bit values"
  	ConstMinusOne := objectMemory integerObjectOf: -1.
  	HasBeenReturnedFromMCPC := objectMemory integerObjectOf: -1.
  	cogMethodZone := cogit methodZone. "Because Slang can't remove intermediate implicit receivers (cogit methodZone foo doesn't reduce to foo())"
  	enableCog := true.
  
  	methodCache := Array new: MethodCacheSize.
  	atCache := Array new: AtCacheTotalSize.
  	self flushMethodCache.
  	self flushAtCache.
  	cogCompiledCodeCompactionCalledFor := false.
  	gcSemaphoreIndex := 0.
  	externalSemaphoreSignalRequests := externalSemaphoreSignalResponses := #().
  	externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
  	externalPrimitiveTableFirstFreeIndex := 0.
  	primitiveTable := self class primitiveTable copy.
- 	primitiveAccessorDepthTable := objectMemory hasSpurMemoryManagerAPI ifTrue:
- 										[self class primitiveAccessorDepthTable].
- 	pluginList := {'' -> self }.
  	mappedPluginEntries := OrderedCollection new.
+ 	objectMemory hasSpurMemoryManagerAPI
+ 		ifTrue:
+ 			[primitiveAccessorDepthTable := Array new: primitiveTable size.
+ 			 pluginList := {}.
+ 			 self loadNewPlugin: '']
+ 		ifFalse:
+ 			[pluginList := {'' -> self }].
  	desiredNumStackPages := desiredEdenBytes := desiredCogCodeSize := 0.
  	"This is initialized on loading the image, but convenient for testing stack page values..."
  	numStackPages := self defaultNumStackPages. 
  	startMicroseconds := Time totalSeconds * 1000000.
  	maxLiteralCountForCompile := MaxLiteralCountForCompile.
  	minBackwardJumpCountForCompile := MinBackwardJumpCountForCompile.
  	flagInterpretedMethods := false.
  
  	"initialize InterpreterSimulator variables used for debugging"
  	byteCount := lastPollCount := sendCount := 0.
  	quitBlock := [^ self].
  	traceOn := true.
  	printSends := printFrameAtEachStep := printBytecodeAtEachStep := false.
  	myBitBlt := BitBltSimulator new setInterpreter: self.
- 	transcript := Transcript.
  	displayForm := 'Display has not yet been installed' asDisplayText form.
  	suppressHeartbeatFlag := deferSmash := deferredSmash := false.
  	systemAttributes := Dictionary new.
  	primTraceLog := CArrayAccessor on: (Array new: 256 withAll: 0).
  	primTraceLogIndex := 0.
  	traceLog := CArrayAccessor on: (Array new: TraceBufferSize withAll: 0).
  	traceLogIndex := 0.
  	traceSources := TraceSources.
  	statCodeCompactionCount := 0.
  	statCodeCompactionUsecs := 0.
  	extSemTabSize := 256!

Item was changed:
  ----- Method: FilePlugin>>primitiveDirectorySetMacTypeAndCreator (in category 'directory primitives') -----
  primitiveDirectorySetMacTypeAndCreator
  
+ 	| creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize okToSet |
- 	| creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize  okToSet |
  	<var: 'creatorStringIndex' type: 'char *'>
  	<var: 'typeStringIndex' type: 'char *'>
  	<var: 'fileNameIndex' type: 'char *'>
  	<export: true>
  
  	creatorString := interpreterProxy stackValue: 0.
  	typeString := interpreterProxy stackValue: 1.
  	fileName := interpreterProxy stackValue: 2.
  	((interpreterProxy isBytes: creatorString)
+ 	 and: [(interpreterProxy isBytes: typeString)
+ 	 and: [(interpreterProxy isBytes: fileName)
+ 	 and: [(interpreterProxy byteSizeOf: creatorString) = 4
+ 	 and: [(interpreterProxy byteSizeOf: typeString) = 4]]]]) ifFalse:
+ 		[^interpreterProxy primitiveFail].
- 			and: [(interpreterProxy byteSizeOf: creatorString)
- 					= 4])
- 		ifFalse: [^interpreterProxy primitiveFail].
- 	((interpreterProxy isBytes: typeString)
- 			and: [(interpreterProxy byteSizeOf: typeString)
- 					= 4])
- 		ifFalse: [^interpreterProxy primitiveFail].
- 	(interpreterProxy isBytes: fileName)
- 		ifFalse: [^interpreterProxy primitiveFail].
  	creatorStringIndex := interpreterProxy firstIndexableField: creatorString.
  	typeStringIndex := interpreterProxy firstIndexableField: typeString.
  	fileNameIndex := interpreterProxy firstIndexableField: fileName.
  	fileNameSize := interpreterProxy byteSizeOf: fileName.
  	"If the security plugin can be loaded, use it to check for permission.
  	If not, assume it's ok"
+ 	sCSFTfn ~= 0 ifTrue:
+ 		[okToSet := self
+ 						cCode: '((sqInt (*)(char *, sqInt))sCSFTfn)(fileNameIndex, fileNameSize)'
+ 						inSmalltalk: [true].
+ 		 okToSet ifFalse:
+ 			[^interpreterProxy primitiveFail]].
- 	sCSFTfn ~= 0
- 		ifTrue: [okToSet := self cCode: ' ((sqInt (*)(char *, sqInt))sCSFTfn)(fileNameIndex, fileNameSize)'.
- 			okToSet
- 				ifFalse: [^interpreterProxy primitiveFail]].
  	(self
+ 		cCode: 'dir_SetMacFileTypeAndCreator(fileNameIndex, fileNameSize, typeStringIndex, creatorStringIndex)'
+ 		inSmalltalk: [true]) ifFalse:
+ 			[^interpreterProxy primitiveFail].
- 			cCode: 'dir_SetMacFileTypeAndCreator(fileNameIndex, fileNameSize,typeStringIndex, creatorStringIndex)'
- 			inSmalltalk: [true])
- 		ifFalse: [^interpreterProxy primitiveFail].
  	interpreterProxy pop: 3!

Item was added:
+ ----- Method: ObjectMemory>>postSnapshot (in category 'image save/restore') -----
+ postSnapshot
+ 	"No op for Spur compatibility."!

Item was changed:
  ----- Method: SpurMemoryManager>>garbageCollectForSnapshot (in category 'snapshot') -----
  garbageCollectForSnapshot
  	self flushNewSpace. "There is no place to put newSpace in the snapshot file."
+ 	self fullGC.
+ 	segmentManager prepareForSnapshot!
- 	self fullGC!

Item was added:
+ ----- Method: SpurMemoryManager>>postSnapshot (in category 'snapshot') -----
+ postSnapshot
+ 	<doNotGenerate>
+ 	segmentManager postSnapshot!

Item was changed:
  VMStructType subclass: #SpurSegmentInfo
+ 	instanceVariableNames: 'segStart segSize swizzle containsPinned savedSegSize lastFreeObject'
- 	instanceVariableNames: 'segStart segSize swizzle containsPinned'
  	classVariableNames: ''
  	poolDictionaries: ''
  	category: 'VMMaker-SpurMemoryManager'!

Item was added:
+ ----- Method: SpurSegmentInfo>>lastFreeObject (in category 'accessing') -----
+ lastFreeObject
+ 	"Answer the value of lastFreeObject"
+ 
+ 	^ lastFreeObject!

Item was added:
+ ----- Method: SpurSegmentInfo>>lastFreeObject: (in category 'accessing') -----
+ lastFreeObject: anObject
+ 	"Set the value of lastFreeObject"
+ 
+ 	^lastFreeObject := anObject!

Item was added:
+ ----- Method: SpurSegmentInfo>>savedSegSize (in category 'accessing') -----
+ savedSegSize
+ 	"Answer the value of savedSegSize"
+ 
+ 	^ savedSegSize!

Item was added:
+ ----- Method: SpurSegmentInfo>>savedSegSize: (in category 'accessing') -----
+ savedSegSize: anObject
+ 	"Set the value of savedSegSize"
+ 
+ 	^savedSegSize := anObject!

Item was added:
+ ----- Method: SpurSegmentManager>>postSnapshot (in category 'snapshot') -----
+ postSnapshot
+ 	"Restore all shortened segments to their proper size,
+ 	 re-freeing the trailing space."
+ 	numSegments - 1 to: 0 by: -1 do:
+ 		[:i|
+ 		 (segments at: i) lastFreeObject ifNotNil:
+ 			[:freeChunk| | address |
+ 			address := (segments at: i) segLimit - manager bridgeSize.
+ 			(segments at: i) segSize: (segments at: i) savedSegSize.
+ 			self bridgeFrom: (segments at: i)
+ 				to: (i < (numSegments - 1) ifTrue: [segments at: i + 1]).
+ 			manager
+ 				addFreeChunkWithBytes: (segments at: i) segLimit - address - manager bridgeSize
+ 				at: address]].
+ 
+ 	"perhaps this should read
+ 		manager setEndOfMemory: 0; assimilateNewSegment: (segments at: numSegments - 1)"
+ 	manager setEndOfMemory: (segments at: numSegments - 1) segLimit - manager bridgeSize!

Item was added:
+ ----- Method: SpurSegmentManager>>prepareForSnapshot (in category 'snapshot') -----
+ prepareForSnapshot
+ 	"shorten all segments by any trailing free space."
+ 	<var: #seg type: #'SpurSegmentInfo *'>
+ 	0 to: numSegments - 1 do:
+ 		[:i|
+ 		 (segments at: i)
+ 			savedSegSize: (segments at: i) segSize;
+ 			lastFreeObject: nil].
+ 
+ 	"Ideally finding the lastFreeObject of each segment would be
+ 	 done in some linear pass through the heap.  But for now KISS."
+ 	manager freeTreeNodesDo:
+ 		[:freeChunk| | next seg |
+ 		next := manager objectAfter: freeChunk limit: manager endOfMemory.
+ 		(manager isSegmentBridge: next) ifTrue:
+ 			[seg := self segmentContainingObj: freeChunk.
+ 			 seg lastFreeObject: freeChunk].
+ 		freeChunk].
+ 
+ 	0 to: numSegments - 1 do:
+ 		[:i|
+ 		 (segments at: i) lastFreeObject ifNotNil:
+ 			[:freeChunk|
+ 			manager detachFreeObject: freeChunk.
+ 			(segments at: i)
+ 				segSize: (manager startOfObject: freeChunk)
+ 						+ manager bridgeSize
+ 						- (segments at: i) segStart.
+ 			self bridgeFrom: (segments at: i)
+ 				to: (i < (numSegments - 1) ifTrue: [segments at: i + 1])]].
+ 
+ 	"perhaps this should read
+ 		manager setEndOfMemory: 0; assimilateNewSegment: (segments at: numSegments - 1)"
+ 	manager setEndOfMemory: (segments at: numSegments - 1) segLimit - manager bridgeSize!

Item was added:
+ ----- Method: SpurSegmentManager>>segmentContainingObj: (in category 'accessing') -----
+ segmentContainingObj: objOop
+ 	<returnTypeC: #'SpurSegmentInfo *'>
+ 	numSegments - 1 to: 0 by: -1 do:
+ 		[:i|
+ 		objOop >= (segments at: i) segStart ifTrue:
+ 			[^self addressOf: (segments at: i)]].
+ 	^nil!

Item was added:
+ ----- Method: StackInterpreter>>codeGeneratorToComputeAccessorDepth (in category 'primitive support') -----
+ codeGeneratorToComputeAccessorDepth
+ 	^VMMaker new
+ 		buildCodeGeneratorForInterpreter: StackInterpreterPrimitives
+ 		includeAPIMethods: false
+ 		initializeClasses: false!

Item was changed:
  ----- Method: StackInterpreter>>snapshot: (in category 'image save/restore') -----
  snapshot: embedded 
  	"update state of active context"
  	| activeContext activeProc rcvr setMacType stackIndex |
  	<var: #setMacType type: #'void *'>
  
  	"For now the stack munging below doesn't deal with more than one argument.
  	 It can, and should."
  	argumentCount ~= 0 ifTrue:
  		[^self primitiveFailFor: PrimErrBadNumArgs].
  
  	"Need to convert all frames into contexts since the snapshot file only holds objects."
  	self push: instructionPointer.
  	activeContext := self voidVMStateForSnapshotFlushingExternalPrimitivesIf: true.
  
  	"update state of active process"
  	activeProc := self activeProcess.
  	objectMemory
  		storePointer: SuspendedContextIndex
  		ofObject: activeProc
  		withValue: activeContext.
  
  	tempOop := activeContext.
  	objectMemory garbageCollectForSnapshot.
  	"Nothing moves from here on so it is safe to grab the activeContext again."
  	activeContext := tempOop.
  	tempOop := 0.
  
  	self successful ifTrue:
  		["Without contexts or stacks simulate
  			rcvr := self popStack. ''pop rcvr''
  			self push: trueObj.
  		  to arrange that the snapshot resumes with true.  N.B. stackIndex is one-relative."
  		stackIndex := self quickFetchInteger: StackPointerIndex ofObject: activeContext.
  		rcvr := objectMemory fetchPointer: stackIndex + CtxtTempFrameStart - 1 ofObject: activeContext.
  		objectMemory
  			storePointerUnchecked: stackIndex + CtxtTempFrameStart - 1
  			ofObject: activeContext
  			withValue: objectMemory trueObject.
  		"now attempt to write the snapshot file"
  		self writeImageFileIO.
  		(self successful and: [embedded not]) ifTrue:
  			["set Mac file type and creator; this is a noop on other platforms"
  			setMacType := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
  			setMacType = 0 ifFalse:
  				[self cCode: '((sqInt (*)(char *, char *, char *))setMacType)(imageName, "STim", "FAST")']].
  		"Without contexts or stacks simulate
  			self pop: 1"
  		objectMemory
  			storePointerUnchecked: StackPointerIndex
  			ofObject: activeContext
  			withValue: (objectMemory integerObjectOf: stackIndex - 1)].
  
+ 	objectMemory postSnapshot.
  	self marryContextInNewStackPageAndInitializeInterpreterRegisters: activeContext.
  	self successful
  		ifTrue: [self push: objectMemory falseObject]
  		ifFalse:
  			[self push: rcvr.
  			 self justActivateNewMethod]!

Item was changed:
  ----- Method: StackInterpreter>>tryLoadNewPlugin:pluginEntries: (in category 'primitive support') -----
  tryLoadNewPlugin: pluginString pluginEntries: pluginEntries
  	"Load the plugin and if on Spur, populate pluginEntries with the prmitives in the plugin."
  	<doNotGenerate>
  	| plugin plugins simulatorClasses |
  	self transcript cr; show: 'Looking for module ', pluginString.
  	"Defeat loading of the FloatArrayPlugin & Matrix2x3Plugin since complications with 32-bit
  	 float support prevent simulation.  If you feel up to tackling this start by implementing
  		cCoerce: value to: cType
  			^cType = 'float'
  				ifTrue: [value asIEEE32BitWord]
  				ifFalse: [value]
  	 in FloatArrayPlugin & Matrix2x3Plugin and then address the issues in the BalloonEnginePlugin.
  	 See http://forum.world.st/Simulating-the-BalloonEnginePlugin-FloatArrayPlugin-amp-Matrix2x3Plugin-primitives-td4734673.html"
  	(#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: pluginString) ifTrue:
  		[self transcript show: ' ... defeated'. ^nil].
  	pluginString isEmpty
  		ifTrue:
  			[plugin := self]
  		ifFalse:
  			[plugins := InterpreterPlugin allSubclasses select: [:psc| psc moduleName asString = pluginString asString].
  			simulatorClasses := (plugins
  									select: [:psc| psc simulatorClass notNil]
  									thenCollect: [:psc| psc simulatorClass]) asSet.
  			simulatorClasses isEmpty ifTrue: [self transcript show: ' ... not found'. ^nil].
  			simulatorClasses size > 1 ifTrue: [^self error: 'This won''t work...'].
  			plugins size > 1 ifTrue:
  				[self transcript show: '...multiple plugin classes; choosing ', plugins last name].
  			plugin := simulatorClasses anyOne newFor: plugins last. "hopefully lowest in the hierarchy..."
  			plugin setInterpreter: objectMemory. "Ignore return value from setInterpreter"
  			(plugin respondsTo: #initialiseModule) ifTrue:
  				[plugin initialiseModule ifFalse:
  					[self transcript show: ' ... initialiser failed'. ^nil]]]. "module initialiser failed"
  	self transcript show: ' ... loaded'.
  	objectMemory hasSpurMemoryManagerAPI ifTrue:
  		[| realPlugin cg |
  		 self transcript show: '...computing accessor depths'.
  		 plugin class isPluginClass
  			ifTrue:
  				[realPlugin := plugin class withAllSuperclasses detect: [:class| class shouldBeTranslated].
  				 cg := realPlugin buildCodeGeneratorUpTo: realPlugin]
  			ifFalse:
+ 				[cg := self codeGeneratorToComputeAccessorDepth.
+ 				 primitiveTable withIndexDo:
+ 					[:prim :index| | depth |
+ 					 prim isSymbol ifTrue:
+ 						[depth := cg accessorDepthForSelector: prim.
+ 						 self assert: depth isInteger.
+ 						 primitiveAccessorDepthTable at: index - 1 put: depth]]].
- 				[cg := VMMaker new
- 							buildCodeGeneratorForInterpreter: StackInterpreter
- 							includeAPIMethods: false
- 							initializeClasses: false].
  		 cg exportedPrimitiveNames do:
  			[:primName| | fnSymbol |
  			 fnSymbol := primName asSymbol.
  			 pluginEntries addLast: {plugin.
  									fnSymbol.
  									[plugin perform: fnSymbol. self].
  									cg accessorDepthForSelector: fnSymbol}].
  		 self transcript show: '...done'].
  	^pluginString asString -> plugin!

Item was changed:
  ----- Method: StackInterpreterSimulator>>initialize (in category 'initialization') -----
  initialize
  	"Initialize the StackInterpreterSimulator when running the interpreter
  	 inside Smalltalk. The primary responsibility of this method is to allocate
  	 Smalltalk Arrays for variables that will be declared as statically-allocated
  	 global arrays in the translated code."
  
  	bootstrapping := false.
+ 	transcript := Transcript.
  
  	objectMemory ifNil:
  		[objectMemory := self class objectMemoryClass simulatorClass new].
  	objectMemory coInterpreter: self.
  
  	"Note: we must initialize ConstMinusOne differently for simulation,
  		due to the fact that the simulator works only with +ve 32-bit values"
  	ConstMinusOne := objectMemory integerObjectOf: -1.
  
  	methodCache := Array new: MethodCacheSize.
  	atCache := Array new: AtCacheTotalSize.
  	self flushMethodCache.
  	gcSemaphoreIndex := 0.
  	externalSemaphoreSignalRequests := externalSemaphoreSignalResponses := #().
  	externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
  	externalPrimitiveTableFirstFreeIndex := 0.
  	primitiveTable := self class primitiveTable copy.
+ 	mappedPluginEntries := OrderedCollection new.
  	objectMemory hasSpurMemoryManagerAPI
  		ifTrue:
+ 			[primitiveAccessorDepthTable := Array new: primitiveTable size.
+ 			 pluginList := {}.
+ 			 self loadNewPlugin: '']
- 			[primitiveAccessorDepthTable := self class primitiveAccessorDepthTable.
- 			 pluginList := {}]
  		ifFalse:
  			[pluginList := {'' -> self }].
- 	mappedPluginEntries := OrderedCollection new.
  	desiredNumStackPages := desiredEdenBytes := 0.
  	"This is initialized on loading the image, but convenient for testing stack page values..."
  	numStackPages := self defaultNumStackPages. 
  	startMicroseconds := Time totalSeconds * 1000000.
  
  	"initialize InterpreterSimulator variables used for debugging"
  	byteCount := 0.
  	sendCount := 0.
  	quitBlock := [^ self].
  	traceOn := true.
  	printSends := printReturns := printFrameAtEachStep := printBytecodeAtEachStep := false.
  	myBitBlt := BitBltSimulator new setInterpreter: self.
- 	transcript := Transcript.
  	displayForm := 'Display has not yet been installed' asDisplayText form.
  	suppressHeartbeatFlag := false.
  	systemAttributes := Dictionary new.
  	extSemTabSize := 256.
  	disableBooleanCheat := false!

Item was added:
+ ----- Method: VMClass class>>initializationOptions (in category 'initialization') -----
+ initializationOptions
+ 	^initializationOptions!