[Vm-dev] VM Maker: VMMaker.oscog-EstebanLorenzano.1319.mcz

[commits at source.squeak.org]

Esteban Lorenzano uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-EstebanLorenzano.1319.mcz

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

Name: VMMaker.oscog-EstebanLorenzano.1319
Author: EstebanLorenzano
Time: 21 May 2015, 9:46:26.77 pm
UUID: e29a9b86-a5ef-4313-a789-9f8e5f2d1bbe
Ancestors: VMMaker.oscog-EstebanLorenzano.1318, VMMaker.oscog-eem.1318

- merged
- applied some suggestions by Eliot

=============== Diff against VMMaker.oscog-EstebanLorenzano.1318 ===============

Item was changed:
  ----- Method: FilePluginSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize:posixPermissions:isSymlink: (in category 'file primitives') -----
  makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize posixPermissions: posixPermissions isSymlink: symlinkFlag
+ 	"This is used just by the PharoVM, at the moment"
- 	<option: #PharoVM>
  	
  	^interpreterProxy
  		makeDirEntryName: entryName 
  		size: entryNameSize
  		createDate: createDate 
  		modDate: modifiedDate
  		isDir: dirFlag 
  		fileSize: fileSize
  		posixPermissions: posixPermissions
  		isSymlink: symlinkFlag!

Item was changed:
  ----- Method: InterpreterPlugin class>>translateInDirectory:doInlining: (in category 'translation') -----
  translateInDirectory: directory doInlining: inlineFlag
  "This is the default method for writing out sources for a plugin. Several classes need special handling, so look at all implementors of this message"
  	| cg fname |
  	 fname := self moduleName, '.c'.
  
  	"don't translate if the file is newer than my timeStamp"
  	(directory entryAt: fname ifAbsent: nil) ifNotNil:
  		[:fstat| | mTime |
  		mTime := fstat modificationTime.
+ 		mTime isInteger ifFalse: [mTime := mTime asSeconds].
- 		(mTime isKindOf: DateAndTime) ifTrue: [ mTime := mTime asSeconds ].
  		 (self allCodeOlderThan: mTime) ifTrue:
  			[^nil]].
  
  	self initialize.
  	cg := self buildCodeGeneratorUpTo: self.
  	cg inferTypesForImplicitlyTypedVariablesAndMethods.
  	self pruneUnusedInterpreterPluginMethodsIn: cg.
  	cg storeCodeOnFile:  (directory fullNameFor: fname) doInlining: inlineFlag.
  	^cg exportedPrimitiveNames asArray!

Item was changed:
  ----- Method: ObjectMemory class>>memoryManagerVersion (in category 'accessing') -----
  memoryManagerVersion 
+ 	^ 'SqueakV3'!
- 	^ 'Blue Book'!

Item was changed:
  ----- Method: SpurMemoryManager>>checkTraversableSortedFreeList (in category 'simulation only') -----
  checkTraversableSortedFreeList
  	| prevFree prevPrevFree freeChunk |
  	<api>
  	<inline: false>
  	prevFree := prevPrevFree := 0.
+ 	firstFreeChunk = 0 ifTrue:
+ 		[^lastFreeChunk = 0].
  	freeChunk := firstFreeChunk.
  	self allOldSpaceEntitiesDo:
  		[:o| | objOop next limit |
  		(self isFreeObject: o) ifTrue:
  			[self assert: o = freeChunk.
  			 next := self nextInSortedFreeListLink: freeChunk given: prevFree.
  			 limit := next = 0 ifTrue: [endOfMemory] ifFalse: [next].
  			 "coInterpreter transcript cr; print: freeChunk; tab; print: o; tab; print: prevFree; nextPutAll: '<->'; print: next; flush."
  			 objOop := freeChunk.
  			 [self oop: (objOop := self objectAfter: objOop) isLessThan: limit] whileTrue:
  				[self assert: (self isFreeObject: objOop) not].
  			 prevPrevFree := prevFree.
  			 prevFree := freeChunk.
  			 freeChunk := next]].
  	self assert: prevFree = lastFreeChunk.
  	self assert: (self nextInSortedFreeListLink: lastFreeChunk given: 0) = prevPrevFree.
  	self assert: freeChunk = 0.
  	^true!

Item was changed:
  ----- Method: SpurMemoryManager>>inOrderPrintFreeTree:printList: (in category 'debug printing') -----
  inOrderPrintFreeTree: freeChunk printList: printNextList
  	"print free chunks in freeTree in order."
  	<api>
  	| next |
  	(next := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: freeChunk) ~= 0 ifTrue:
  		[self inOrderPrintFreeTree: next printList: printNextList].
+ 	self printFreeChunk: freeChunk printAsTreeNode: true.
- 	self printFreeChunk: freeChunk isNextChunk: false.
  	printNextList ifTrue:
  		[next := freeChunk.
  		 [(next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: next) ~= 0] whileTrue:
  			[coInterpreter tab.
+ 			 self printFreeChunk: next printAsTreeNode: false]].
- 			 self printFreeChunk: next isNextChunk: true]].
  	(next := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: freeChunk) ~= 0 ifTrue:
  		[self inOrderPrintFreeTree: next printList: printNextList]!

Item was changed:
  ----- Method: SpurMemoryManager>>nextInSortedFreeListLink:given: (in category 'compaction') -----
  nextInSortedFreeListLink: freeChunk given: prevFree
  	 "Answer the next free free chunk using the xor trick to use only one field, see e.g.
  		The Art of Computer Programming, Vol 1, D.E. Knuth, 3rd Ed, Sec 2.2.4 `Circular Lists', exercise. 18
  		http://en.wikipedia.org/wiki/XOR_linked_list."
  	<api>
+ 	^((self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk) bitXor: prevFree) asUnsignedInteger!
- 	^(self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk) bitXor: prevFree!

Item was changed:
  ----- Method: SpurMemoryManager>>printFreeChunk: (in category 'debug printing') -----
  printFreeChunk: freeChunk
  	<api>
+ 	self printFreeChunk: freeChunk printAsTreeNode: true!
- 	self printFreeChunk: freeChunk isNextChunk: false!

Item was removed:
- ----- Method: SpurMemoryManager>>printFreeChunk:isNextChunk: (in category 'debug printing') -----
- printFreeChunk: freeChunk isNextChunk: isNextChunk
- 	| numBytes |
- 	numBytes := self bytesInObject: freeChunk.
- 	coInterpreter
- 		print: 'freeChunk '; printHexPtrnp: freeChunk;
- 		print: ' bytes '; printNum: numBytes;
- 		print: ' next '; printHexPtrnp: (self fetchPointer: self freeChunkNextIndex
- 											ofFreeChunk: freeChunk).
- 	(numBytes >= (self numFreeLists * self allocationUnit)
- 	 and: [isNextChunk not]) ifTrue:
- 		[coInterpreter
- 			print: ' ^ '; printHexPtrnp: (self fetchPointer: self freeChunkParentIndex
- 											ofFreeChunk: freeChunk);
- 			print: ' < '; printHexPtrnp: (self fetchPointer: self freeChunkSmallerIndex
- 											ofFreeChunk: freeChunk);
- 			print: ' > '; printHexPtrnp: (self fetchPointer: self freeChunkLargerIndex
- 											ofFreeChunk: freeChunk)].
- 	coInterpreter cr!

Item was added:
+ ----- Method: SpurMemoryManager>>printFreeChunk:printAsTreeNode: (in category 'debug printing') -----
+ printFreeChunk: freeChunk printAsTreeNode: printAsTreeNode
+ 	| numBytes |
+ 	numBytes := self bytesInObject: freeChunk.
+ 	coInterpreter
+ 		print: 'freeChunk '; printHexPtrnp: freeChunk;
+ 		print: ' bytes '; printNum: numBytes;
+ 		print: ' next '; printHexPtrnp: (self fetchPointer: self freeChunkNextIndex
+ 											ofFreeChunk: freeChunk).
+ 	(numBytes >= (self numFreeLists * self allocationUnit)
+ 	 and: [printAsTreeNode]) ifTrue:
+ 		[coInterpreter
+ 			print: ' ^ '; printHexPtrnp: (self fetchPointer: self freeChunkParentIndex
+ 											ofFreeChunk: freeChunk);
+ 			print: ' < '; printHexPtrnp: (self fetchPointer: self freeChunkSmallerIndex
+ 											ofFreeChunk: freeChunk);
+ 			print: ' > '; printHexPtrnp: (self fetchPointer: self freeChunkLargerIndex
+ 											ofFreeChunk: freeChunk)].
+ 	coInterpreter cr!

Item was added:
+ ----- Method: SpurMemoryManager>>printSortedFreeList (in category 'debug printing') -----
+ printSortedFreeList
+ 	<api>
+ 	| freeChunk prevFree nextFree |
+ 	(firstFreeChunk > 0 and: [lastFreeChunk > firstFreeChunk]) ifFalse:
+ 		[coInterpreter print: 'sorted free list empty or corrupt'; cr.
+ 		 ^self].
+ 	freeChunk := firstFreeChunk.
+ 	prevFree := 0.
+ 	[((self addressCouldBeObj: freeChunk)
+ 	 and: [self isFreeObject: freeChunk]) ifFalse:
+ 		[coInterpreter printHexnp: freeChunk; print: ' is not a free chunk!!' ; cr.
+ 		 ^self].
+ 	 self printFreeChunk: freeChunk printAsTreeNode: false.
+ 	 freeChunk ~= lastFreeChunk] whileTrue:
+ 		[nextFree := self nextInSortedFreeListLink: freeChunk given: prevFree.
+ 		 prevFree := freeChunk.
+ 		 freeChunk := nextFree]!

Item was changed:
  ----- Method: TMethod>>emitCCodeOn:generator: (in category 'C code generation') -----
  emitCCodeOn: aStream generator: aCodeGen
  	"Emit C code for this method onto the given stream.
  	 All calls to inlined methods should already have been expanded."
  
  	aCodeGen currentMethod: self.
  	self emitCCommentOn: aStream.	"place method comment before function"
  	aStream cr. 
  	self emitCFunctionPrototype: aStream generator: aCodeGen isPrototype: false.
  	aStream cr; nextPut: ${.
  	aStream cr; tab;
+ 		nextPutAll: '/* '; nextPutAll: self definingClass name; nextPutAll: '>>#'; nextPutAll: self selector; nextPutAll: ' */'.	
- 		nextPutAll: '// '; nextPutAll: self definingClass name; nextPutAll: '>>#'; nextPutAll: self selector.	
  	self emitCLocalsOn: aStream generator: aCodeGen.
  	aCodeGen
  		pushScope: declarations
  		while: [parseTree emitCCodeOn: aStream level: 1 generator: aCodeGen].
  	aStream nextPut: $}; cr!

Item was changed:
  ----- Method: VMMaker>>needsToRegenerateCogitFile (in category 'generate sources') -----
  needsToRegenerateCogitFile
  	"Check the timestamp for the relevant classes and then the timestamp for the main source file (e.g. interp.c)
  	 file if it already exists. Answer if the file needs regenerating."
  
  	| cogitClass cogitClasses tStamp |
  	cogitClasses := (cogitClass := self interpreterClass cogitClass) withAllSuperclasses copyUpThrough: Cogit.
  	cogitClasses addAllLast: (cogitClass ancilliaryClasses: self options).
  	tStamp := cogitClasses inject: 0 into: [:tS :cl| tS max: cl timeStamp].
  
  	"don't translate if the file is newer than my timeStamp"
  	(self coreVMDirectory entryAt: cogitClass processorSpecificSourceFileName ifAbsent: [nil]) ifNotNil:
  		[:fstat| | mTime |
  		mTime := fstat modificationTime.
+ 		mTime isInteger ifFalse: [mTime := mTime asSeconds].
- 		(mTime isKindOf: DateAndTime) ifTrue: [ mTime := mTime asSeconds ]. 
  		tStamp < mTime ifTrue:
  			[^self confirm: ('The ', self configurationNameIfAny, cogitClass printString,
  							', ', cogitClass activeCompilerClass, '\classes have not been modified since the ',
  							cogitClass processorSpecificSourceFileName,
  							' source file\was last generated.  Do you still want to regenerate it?') withCRs]].
  	^true!

Item was changed:
  ----- Method: VMMaker>>needsToRegenerateInterpreterFile (in category 'initialize') -----
  needsToRegenerateInterpreterFile
  	"Check the timestamp for the relevant classes and then the timestamp for the main
  	 source file (e.g. interp.c) if it already exists.  Answer if the file needs regenerating."
  
  	| classes tStamp |
  	classes := self interpreterClass withAllSuperclasses copyUpTo: VMClass.
  	self interpreterClass objectMemoryClass ifNotNil:
  		[:objectMemoryClass|
  		classes addAllLast: (objectMemoryClass withAllSuperclasses copyUpTo: VMClass)].
  	classes copy do:
  		[:class| classes addAllLast: (class ancilliaryClasses: self options)].
  	tStamp := classes inject: 0 into: [:tS :cl| tS max: cl timeStamp].
  
  	"don't translate if the file is newer than my timeStamp"
  	(self coreVMDirectory entryAt: self interpreterFilename ifAbsent: [nil]) ifNotNil:
  		[:fstat| | mTime |
  		mTime := fstat modificationTime.
+ 		mTime isInteger ifFalse: [mTime := mTime asSeconds].
- 		(mTime isKindOf: DateAndTime) ifTrue: [ mTime := mTime asSeconds ].
  		tStamp < mTime ifTrue:
  			[^self confirm: 'The ', self configurationNameIfAny, 'interpreter classes have not been modified since\ the interpreter file was last generated.\Do you still want to regenerate the source file?' withCRs]].
  	^true
  !

Item was changed:
  ----- Method: VMMakerTool class>>initialize (in category 'instance creation') -----
  initialize
  
  	Smalltalk at: #TheWorldMenu ifPresent: [ :class |
+ 		((class compiledMethodAt: #registerOpenCommand: ifAbsent: [^self]) sendsSelector: #deprecated:) 
+ 			ifFalse: [class registerOpenCommand: (Array with: 'VMMaker' with: (Array with: self with: #openInWorld))]]
- 		class class methodDict at: #registerOpenCommand: ifPresent: [ :method |
- 			(method sendsSelector: #deprecated:) 
- 				ifFalse: [ class registerOpenCommand: (Array with: 'VMMaker' with: (Array with: self with: #openInWorld)) ] ] ]
  	!