[Vm-dev] VM Maker: VMMaker.oscog-eem.617.mcz
commits at source.squeak.org
commits at source.squeak.org
Mon Feb 17 20:23:25 UTC 2014
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.617.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.617
Author: eem
Time: 17 February 2014, 12:19:53.448 pm
UUID: 3683f3df-b4c0-4145-9b2c-758146d91de7
Ancestors: VMMaker.oscog-tty.616
Merge with VMMaker.oscog-tty.616 & VMMaker.oscog-dtl.615.
Recommit changes in misnamed .VMMaker.oscog-eem.615 et al:
Make Spur snapshot avoid writing trailing free space in each
segment to the image file
Fix initialization of primitiveAccessorDepthTable during simulation.
Use Smalltalk vm getSystemAttribute: instead of plain old
Smalltalk getSystemAttribute:
Some musings on Spur compaction.
=============== Diff against VMMaker.oscog-tty.616 ===============
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: CogVMSimulator>>primitiveGetAttribute (in category 'other primitives') -----
primitiveGetAttribute
"Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."
| index s attribute |
index := self stackIntegerValue: 0.
self successful ifTrue: [
+ attribute := systemAttributes at: index ifAbsent: [Smalltalk vm getSystemAttribute: index].
- attribute := systemAttributes at: index ifAbsent: [Smalltalk getSystemAttribute: index].
attribute ifNil: [ ^self primitiveFail ].
s := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: attribute size.
1 to: attribute size do: [ :i |
objectMemory storeByte: i-1 ofObject: s withValue: (attribute at: i) asciiValue].
+ self pop: 2 "rcvr, attr" thenPush: s]!
- self pop: 2. "rcvr, attr"
- self push: s]!
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 changed:
----- Method: InterpreterSimulator>>primitiveGetAttribute (in category 'other primitives') -----
primitiveGetAttribute
"Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."
| attr s attribute |
attr := self stackIntegerValue: 0.
successFlag ifTrue: [
+ attribute := Smalltalk vm getSystemAttribute: attr.
- attribute := Smalltalk getSystemAttribute: attr.
attribute ifNil: [ ^self primitiveFail ].
s := self instantiateClass: (self splObj: ClassByteString) indexableSize: attribute size.
1 to: attribute size do: [ :i |
self storeByte: i-1 ofObject: s withValue: (attribute at: i) asciiValue].
+ self pop: 2 "rcvr, attr" thenPush: s].
- self pop: 2. "rcvr, attr"
- self push: s].
!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>primitiveGetAttribute (in category 'other primitives') -----
primitiveGetAttribute
"Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."
| attr s attribute |
attr := self stackIntegerValue: 0.
self successful ifTrue: [
+ attribute := Smalltalk vm getSystemAttribute: attr.
- attribute := Smalltalk getSystemAttribute: attr.
attribute ifNil: [ ^self primitiveFail ].
s := self instantiateClass: (self splObj: ClassByteString) indexableSize: attribute size.
1 to: attribute size do: [ :i |
self storeByte: i-1 ofObject: s withValue: (attribute at: i) asciiValue].
+ self pop: 2 "rcvr, attr" thenPush: s].
- self pop: 2. "rcvr, attr"
- self push: s].
!
Item was added:
+ ----- Method: ObjectMemory>>postSnapshot (in category 'image save/restore') -----
+ postSnapshot
+ "No op for Spur compatibility."!
Item was added:
+ ----- Method: SpurMemoryManager>>abstractCompaction (in category 'compaction - analysis') -----
+ abstractCompaction
+ "This method answers a rough estimate of compactibility."
+ <doNotGenerate>
+ | lowestFree freeChunks used movable |
+ lowestFree := SmallInteger maxVal.
+ freeChunks := Set new.
+ used := Set new.
+ movable := Set new.
+ self allObjectsInFreeTreeDo:
+ [:f|
+ (self addressAfter: f) < endOfMemory ifTrue:
+ [freeChunks add: f.
+ f < lowestFree ifTrue: [lowestFree := f]]].
+ self allOldSpaceObjectsFrom: lowestFree do:
+ [:o| | size delta best |
+ size := self bytesInObject: o.
+ delta := SmallInteger maxVal.
+ freeChunks do: [:f| | fs |
+ ((fs := self bytesInObject: f) >= size) ifTrue:
+ [delta > (fs - size) ifTrue:
+ [delta := fs - size. best := f]]].
+ best ifNotNil:
+ [movable add: o.
+ used add: (freeChunks remove: best)]].
+ ^{ totalFreeOldSpace. movable inject: 0 into: [:s :o| s + (self bytesInObject: o)]. used inject: 0 into: [:s :o| s + (self bytesInObject: o)] }!
Item was added:
+ ----- Method: SpurMemoryManager>>abstractPigCompaction (in category 'compaction - analysis') -----
+ abstractPigCompaction
+ "This method answers a rough estimate of compactibility using a pig (a large free chunk)."
+ <doNotGenerate>
+ | pig pork moved unmoved nmoved nunmoved |
+ pig := self findAPig.
+ pork := self bytesInObject: pig.
+ moved := unmoved := nmoved := nunmoved := 0.
+ self allOldSpaceObjectsFrom: pig do:
+ [:o| | bytes |
+ bytes := self bytesInObject: o.
+ bytes <= pork
+ ifTrue:
+ [moved := moved + bytes.
+ nmoved := nmoved + 1.
+ pork := pork - bytes]
+ ifFalse:
+ [unmoved := unmoved + bytes.
+ nunmoved := nunmoved + 1]].
+ ^{ self bytesInObject: pig. pork. moved. nmoved. unmoved. nunmoved }!
Item was added:
+ ----- Method: SpurMemoryManager>>biggies (in category 'compaction - analysis') -----
+ biggies
+ "This method answers a sorted collection of the objects >= 1,000,000 bytes long,
+ above the lowest large free chunk, sandwiched between nilObj and the end of memory."
+ <doNotGenerate>
+ | lowestFree biggies |
+ lowestFree := SmallInteger maxVal.
+ self allObjectsInFreeTreeDo:
+ [:f| (self addressAfter: f) < endOfMemory ifTrue: [f < lowestFree ifTrue: [lowestFree := f]]].
+ biggies := SortedCollection new.
+ self allOldSpaceObjectsFrom: lowestFree do:
+ [:f|
+ (self bytesInObject: f) >= 1000000 ifTrue:
+ [biggies add: f]].
+ ^{{nilObj hex. #nil}}, (biggies collect: [:f| {f hex. self bytesInObject: f}]), {{endOfMemory hex. #endOfMemory}}!
Item was changed:
----- Method: SpurMemoryManager>>compact (in category 'compaction') -----
compact
"We'd like to use exact fit followed by best fit, but best-fit is complex to implement
and potentially expensive. So just use exactFit followed, if necessary, by first-fit."
<inline: false>
+ self assert: (firstFreeChunk = 0 or: [self isFreeObject: firstFreeChunk]).
self exactFitCompact.
+ self assert: (firstFreeChunk = 0
+ or: [(self isFreeObject: firstFreeChunk)
+ or: [self isValidClassIndex: (self classIndexOf: firstFreeChunk)]]).
highestObjects usedSize > 0 ifTrue:
[self firstFitCompact]!
Item was added:
+ ----- Method: SpurMemoryManager>>compactionIssues (in category 'compaction - analysis') -----
+ compactionIssues
+ <doNotGenerate>
+ "Compaction isn't working well. It rarely moves more than a few tens of kilobytes. Why?
+ Load an image and before you run it, or just before a GC, run these anaylsis routines.
+ e.g.
+ self abstractCompaction #(63230272 75456 63210648)
+ shows we can move 75456 bytes of objects, but that would use 63210648 of free space.
+ i.e. there are lots of big free chunks in play, not many small ones that fit the bill.
+
+ self largeFreeChunkDistribution
+ #( #('16r31C788' #nil)
+ #('16r1423AC0' 2061864)
+ #('16r1B705E8' 1515200)
+ #('16r1D31D20' 2011152)
+ #('16r1F37818' 1491480)
+ #('16r2225968' 1450512)
+ #('16r24C92C8' 48575672) (16r24C92C8 + 48575672) hex '16r531C780' a free chunk
+ #('16r531C788' #endOfMemory))
+ shows there's plenty of large free chunks. And the trailing 16-byte free chunk shows coallescing is not working properly.
+
+ self biggies #(#('16r31C788' #nil) #('16r531C788' #endOfMemory))
+ shows there are no large objects to be moved.
+
+ So... looks like compaction should hold onto the lowest large chunk and preferentially move objects into that.
+ Let's call it a pig. Compaction needs to whittle away at the pig.
+
+ e.g.
+ self abstractPigCompaction #(2061864 0 2061864 18759 2018224 34757)
+ shows we can move 18759 objects that will occupy 2018224 bytes into that
+ low pig of 2061864 bytes."!
Item was changed:
----- Method: SpurMemoryManager>>emptyObjStack: (in category 'obj stacks') -----
emptyObjStack: objStack
"Remove all the entries on the stack. Do so by setting Topx to 0
on the first page, and adding all subsequent pages to the free list."
| nextPage nextNextPage |
+ objStack = nilObj ifTrue:
+ [^self].
self assert: (self isValidObjStack: objStack).
self storePointer: ObjStackTopx ofObject: objStack withValue: 0.
nextPage := self fetchPointer: ObjStackNextx ofObject: objStack.
[nextPage ~= 0] whileTrue:
[nextNextPage := self fetchPointer: ObjStackNextx ofObject: nextPage.
self storePointer: ObjStackFreex
ofObjStack: nextPage
withValue: (self fetchPointer: ObjStackFreex ofObject: objStack).
self storePointer: ObjStackNextx ofObjStack: nextPage withValue: 0.
self storePointer: ObjStackFreex ofObjStack: objStack withValue: nextPage.
nextPage := nextNextPage].
self storePointer: ObjStackNextx ofObjStack: objStack withValue: 0.
self assert: (self isValidObjStack: objStack)!
Item was changed:
----- Method: SpurMemoryManager>>exactFitCompact (in category 'compaction') -----
exactFitCompact
"Compact all of memory above firstFreeChunk using exact-fit, assuming free
space is sorted and that as many of the the highest objects as will fit are
recorded in highestObjects. Don't move pinned objects.
Note that we don't actually move; we merely copy and forward. Eliminating
forwarders will be done in a final pass. Leave the objects that don't fit
exactly (the misfits), and hence aren't moved, in highestObjects."
<inline: false>
| misfits first nfits nmiss nHighest nMisses savedLimit |
<var: #misfits type: #usqInt>
self checkFreeSpace.
totalFreeOldSpace = 0 ifTrue: [^self].
highestObjects isEmpty ifTrue:
[^self].
nfits := nmiss := 0.
misfits := highestObjects last + self wordSize.
[statCompactPassCount := statCompactPassCount + 1.
highestObjects from: misfits - self wordSize reverseDo:
[:o| | b |
(self oop: o isGreaterThan: firstFreeChunk) ifFalse:
[highestObjects first: misfits.
coInterpreter print: 'exactFitCompact fits: '; printNum: nfits; print: ' misfits: '; printNum: nmiss; cr.
^self].
((self isForwarded: o) or: [self isPinned: o]) ifFalse:
[b := self bytesInObject: o.
(self allocateOldSpaceChunkOfExactlyBytes: b suchThat: [:f| f < o])
ifNil:
[nmiss := nmiss + 1.
misfits := misfits - self wordSize.
misfits < highestObjects start ifTrue:
[misfits := highestObjects limit - self wordSize].
self longAt: misfits put: o]
ifNotNil:
[:f|
nfits := nfits + 1.
self copyAndForward: o withBytes: b toFreeChunk: f.
"here's a wrinkle; if the firstFreeChunk is allocated to a small object and the firstFreeChunk
is a large chunk then firstFreeChunk will no longer point to an object header. So check and
adjust firstFreeChunk if it is assigned to."
f = firstFreeChunk ifTrue:
[firstFreeChunk := self objectStartingAt: f]]]].
self checkFreeSpace.
"now highestObjects contains only misfits, if any, from misfits to last.
set first to first failure and refill buffer. next cycle will add more misfits.
give up on exact-fit when half of the highest objects fail to fit."
first := self longAt: highestObjects first.
self assert: (self oop: first isGreaterThan: firstFreeChunk).
nHighest := highestObjects usedSize.
highestObjects first: misfits.
nMisses := highestObjects usedSize.
nMisses > (nHighest // 2) ifTrue:
[coInterpreter print: 'exactFitCompact fits: '; printNum: nfits; print: ' misfits: '; printNum: nmiss; cr.
^self].
savedLimit := self moveMisfitsToTopOfHighestObjects: misfits.
+ self fillHighestObjectsWithMovableObjectsFromFirstFreeChunkUpTo: first.
- self fillHighestObjectsWithMovableObjectsFrom: firstFreeChunk upTo: first.
misfits := self moveMisfitsInHighestObjectsBack: savedLimit.
highestObjects usedSize > 0] whileTrue!
Item was removed:
- ----- Method: SpurMemoryManager>>fillHighestObjectsWithMovableObjectsFrom:upTo: (in category 'compaction') -----
- fillHighestObjectsWithMovableObjectsFrom: startObj upTo: limitObj
- "Refill highestObjects with movable objects up to, but not including limitObj.
- c.f. the loop in freeUnmarkedObjectsNilUnmarkedWeaklingSlotsAndSortAndCoalesceFreeSpace."
- | lastHighest highestObjectsWraps firstFree |
- highestObjects resetAsEmpty.
- lastHighest := highestObjects last.
- highestObjectsWraps := firstFree := 0.
- self allOldSpaceEntitiesFrom: startObj do:
- [:o|
- (self oop: o isGreaterThanOrEqualTo: limitObj) ifTrue:
- [highestObjects last: lastHighest.
- (firstFree ~= 0 and: [(self isFreeObject: firstFreeChunk) not]) ifTrue:
- [firstFreeChunk := firstFree].
- ^self].
- (self isFreeObject: o)
- ifTrue: [firstFree = 0 ifTrue:
- [firstFree := o]]
- ifFalse:
- [((self isForwarded: o) or: [self isPinned: o]) ifFalse:
- [false "conceptually...: "
- ifTrue: [highestObjects addLast: o]
- ifFalse: "but we inline so we can use the local lastHighest"
- [(lastHighest := lastHighest + self wordSize) >= highestObjects limit ifTrue:
- [highestObjectsWraps := highestObjectsWraps + 1.
- lastHighest := highestObjects start].
- self longAt: lastHighest put: o]]]].
- highestObjects last: lastHighest.
- (firstFree ~= 0 and: [(self isFreeObject: firstFreeChunk) not]) ifTrue:
- [firstFreeChunk := firstFree]!
Item was added:
+ ----- Method: SpurMemoryManager>>fillHighestObjectsWithMovableObjectsFromFirstFreeChunkUpTo: (in category 'compaction') -----
+ fillHighestObjectsWithMovableObjectsFromFirstFreeChunkUpTo: limitObj
+ "Refill highestObjects with movable objects up to, but not including limitObj.
+ c.f. the loop in freeUnmarkedObjectsAndSortAndCoalesceFreeSpace."
+ | lastHighest highestObjectsWraps firstFree |
+ self assert: (firstFreeChunk = 0
+ or: [(self isFreeObject: firstFreeChunk)
+ or: [self isValidClassIndex: (self classIndexOf: firstFreeChunk)]]).
+ highestObjects resetAsEmpty.
+ lastHighest := highestObjects last.
+ highestObjectsWraps := firstFree := 0.
+ self allOldSpaceEntitiesFrom: firstFreeChunk do:
+ [:o|
+ (self oop: o isGreaterThanOrEqualTo: limitObj) ifTrue:
+ [highestObjects last: lastHighest.
+ (self isFreeObject: firstFreeChunk) ifFalse:
+ [firstFreeChunk := firstFree = 0 ifTrue: [limitObj] ifFalse: [firstFree]].
+ ^self].
+ (self isFreeObject: o)
+ ifTrue: [firstFree = 0 ifTrue:
+ [firstFree := o]]
+ ifFalse:
+ [((self isForwarded: o) or: [self isPinned: o]) ifFalse:
+ [false "conceptually...: "
+ ifTrue: [highestObjects addLast: o]
+ ifFalse: "but we inline so we can use the local lastHighest"
+ [(lastHighest := lastHighest + self wordSize) >= highestObjects limit ifTrue:
+ [highestObjectsWraps := highestObjectsWraps + 1.
+ lastHighest := highestObjects start].
+ self longAt: lastHighest put: o]]]].
+ highestObjects last: lastHighest.
+ (self isFreeObject: firstFreeChunk) ifFalse:
+ [firstFreeChunk := firstFree = 0 ifTrue: [limitObj] ifFalse: [firstFree]].
+ self assert: (firstFreeChunk = 0
+ or: [(self isFreeObject: firstFreeChunk)
+ or: [self isValidClassIndex: (self classIndexOf: firstFreeChunk)]])!
Item was added:
+ ----- Method: SpurMemoryManager>>findAPig (in category 'compaction - analysis') -----
+ findAPig
+ "Answer a large low free chuink."
+ <doNotGenerate>
+ | pig |
+ self allObjectsInFreeTreeDo:
+ [:f|
+ (self bytesInObject: f) >= 1000000 ifTrue:
+ [(pig isNil or: [pig > f]) ifTrue:
+ [pig := f]]].
+ ^pig!
Item was changed:
----- Method: SpurMemoryManager>>firstFitCompact (in category 'compaction') -----
firstFitCompact
"Compact all of memory above firstFreeChunk using first-fit, assuming free
space is sorted and that as many of the the highest objects as will fit are
recorded in highestObjects. Don't move pinned objects.
Note that we don't actually move; we merely copy and forward. Eliminating
forwarders will be done in a final pass."
<inline: false>
| first nhits nmisses |
self checkFreeSpace.
totalFreeOldSpace = 0 ifTrue: [^self].
highestObjects isEmpty ifTrue:
[^self].
nhits := nmisses := 0.
[statCompactPassCount := statCompactPassCount + 1.
highestObjects reverseDo:
[:o| | b |
(self oop: o isLessThanOrEqualTo: firstFreeChunk) ifTrue:
[coInterpreter print: 'firstFitCompact fits: '; printNum: nhits; print: ' misfits: '; printNum: nmisses; cr.
^self].
((self isForwarded: o) or: [self isPinned: o]) ifFalse:
[b := self bytesInObject: o.
(self allocateOldSpaceChunkOfBytes: b suchThat: [:f| f < o])
ifNil:
[nmisses := nmisses + 1]
ifNotNil:
[:f|
nhits := nhits + 1.
self copyAndForward: o withBytes: b toFreeChunk: f.
"here's a wrinkle; if the firstFreeChunk is allocated to a small object and the firstFreeChunk
is a large chunk then firstFreeChunk will no longer point to an object header. So check and
adjust firstFreeChunk if it is assigned to."
f = firstFreeChunk ifTrue:
[firstFreeChunk := self objectStartingAt: f].
self assert: (lastSubdividedFreeChunk = 0
or: [(self addressAfter: (self objectStartingAt: f)) = lastSubdividedFreeChunk])]]].
self checkFreeSpace.
first := self longAt: highestObjects first.
self assert: (self oop: first isGreaterThan: firstFreeChunk).
+ self fillHighestObjectsWithMovableObjectsFromFirstFreeChunkUpTo: first.
- self fillHighestObjectsWithMovableObjectsFrom: firstFreeChunk upTo: first.
highestObjects usedSize > 0] whileTrue.
coInterpreter print: 'firstFitCompact fits: '; printNum: nhits; print: ' misfits: '; printNum: nmisses; cr!
Item was changed:
----- Method: SpurMemoryManager>>freeUnmarkedObjectsAndSortAndCoalesceFreeSpace (in category 'gc - global') -----
freeUnmarkedObjectsAndSortAndCoalesceFreeSpace
"Sweep all of old space, freeing unmarked objects, coalescing free chunks, and sorting free space.
Small free chunks are sorted in address order on each small list head. Large free chunks
are sorted on the sortedFreeChunks list. Record as many of the highest objects as there
is room for in highestObjects, a circular buffer, for the use of exactFitCompact. Use
unused eden space for highestObjects. If highestObjects does not wrap, store 0
at highestObjects last. Record the lowest free object in firstFreeChunk. Let the
segmentManager mark which segments contain pinned objects via notePinned:."
| lastLargeFree lastHighest highestObjectsWraps sortedFreeChunks |
<inline: false>
<var: #lastHighest type: #usqInt>
self checkFreeSpace.
scavenger forgetUnmarkedRememberedObjects.
segmentManager prepareForGlobalSweep."for notePinned:"
"for sorting free space throw away the list heads, rebuilding them for small free chunks below."
self resetFreeListHeads.
highestObjects initializeStart: freeStart limit: scavenger eden limit.
lastHighest := highestObjects start - self wordSize. "a.k.a. freeStart - wordSize"
highestObjectsWraps := 0.
self assert: highestObjects limit - highestObjects start // self wordSize >= 1024.
firstFreeChunk := sortedFreeChunks := lastLargeFree := 0.
"Note that if we were truly striving for performance we could split the scan into
two phases, one up to the first free object and one after, which would remove
the need to test firstFreeChunk when filling highestObjects."
self allOldSpaceEntitiesForCoalescingDo:
[:o|
+ self assert: (firstFreeChunk = 0 or: [self isFreeObject: firstFreeChunk]).
+ (self isMarked: o)
- (self isMarked: o)
ifTrue: "forwarders should have been followed in markAndTrace:"
[self assert: (self isForwarded: o) not.
self setIsMarkedOf: o to: false. "this will unmark bridges. undo the damage in notePinned:"
(self isPinned: o) ifTrue:
[segmentManager notePinned: o].
firstFreeChunk ~= 0 ifTrue:
[false "conceptually...: "
ifTrue: [highestObjects addLast: o]
ifFalse: "but we inline so we can use the local lastHighest"
[(lastHighest := lastHighest + self wordSize) >= highestObjects limit ifTrue:
[highestObjectsWraps := highestObjectsWraps + 1.
lastHighest := highestObjects start].
self longAt: lastHighest put: o]]]
ifFalse: "unmarked; two cases, an unreachable object or a free chunk."
[| here limit next |
self assert: (self isRemembered: o) not. "scavenger should have cleared this above"
here := o.
limit := endOfMemory - self bridgeSize.
next := self objectAfter: here limit: limit.
[next = limit or: [self isMarked: next]] whileFalse: "coalescing; rare case"
[self assert: (self isRemembered: o) not.
statCoalesces := statCoalesces + 1.
here := self coalesce: here and: next.
next := self objectAfter: here limit: limit].
- firstFreeChunk = 0 ifTrue:
- [firstFreeChunk := here].
(self isLargeFreeObject: here)
ifTrue:
[self setFree: here.
lastLargeFree = 0
ifTrue: [sortedFreeChunks := lastLargeFree := here]
ifFalse:
[self storePointer: self freeChunkNextAddressIndex
ofFreeChunk: lastLargeFree
withValue: here].
lastLargeFree := here]
ifFalse:
+ [self freeSmallObject: here].
+ firstFreeChunk = 0 ifTrue:
+ [self assert: (self isFreeObject: here).
+ firstFreeChunk := here]]].
- [self freeSmallObject: here]]].
highestObjects last: lastHighest.
highestObjectsWraps ~= 0 ifTrue:
[highestObjects first: (lastHighest + self wordSize >= highestObjects limit
ifTrue: [highestObjects start]
ifFalse: [lastHighest + self wordSize])].
lastLargeFree ~= 0 ifTrue:
[self storePointer: self freeChunkNextAddressIndex ofFreeChunk: lastLargeFree withValue: 0].
totalFreeOldSpace := self reverseSmallListHeads.
totalFreeOldSpace := totalFreeOldSpace + (self rebuildFreeTreeFrom: sortedFreeChunks).
self checkFreeSpace.
self touch: highestObjectsWraps!
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 changed:
----- Method: SpurMemoryManager>>globalGarbageCollect (in category 'gc - global') -----
globalGarbageCollect
self runLeakCheckerForFullGC: true.
self assert: self validObjStacks.
self markObjects.
self nilUnmarkedWeaklingSlots.
self freeUnmarkedObjectsAndSortAndCoalesceFreeSpace.
self runLeakCheckerForFullGC: true excludeUnmarkedNewSpaceObjs: true.
self compact.
self eliminateAndFreeForwarders.
self assert: self validObjStacks.
+ self assert: (self isEmptyObjStack: weaklingStack).
self assert: self allObjectsUnmarked.
self runLeakCheckerForFullGC: true!
Item was changed:
----- Method: SpurMemoryManager>>initializeObjectMemory: (in category 'initialization') -----
initializeObjectMemory: bytesToShift
"Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks."
"Assume: image reader initializes the following variables:
memory
memoryLimit
specialObjectsOop
lastHash
"
<inline: false>
| freeListObj |
"Catch mis-initializations leading to bad translations to C"
self assert: BaseHeaderSize = self baseHeaderSize.
self bootstrapping ifFalse:
[self
initSegmentBridgeWithBytes: self bridgeSize
at: endOfMemory - self bridgeSize].
segmentManager adjustSegmentSwizzlesBy: bytesToShift.
"image may be at a different address; adjust oops for new location"
self adjustAllOopsBy: bytesToShift.
specialObjectsOop := segmentManager swizzleObj: specialObjectsOop.
"heavily used special objects"
nilObj := self splObj: NilObject.
falseObj := self splObj: FalseObject.
trueObj := self splObj: TrueObject.
"In Cog we insist that nil, true & false are next to each other (Cogit generates tighter
conditional branch code as a result). In addition, Spur places the free lists and
class table root page immediately following them."
self assert: nilObj = oldSpaceStart.
self assert: falseObj = (self objectAfter: nilObj).
self assert: trueObj = (self objectAfter: falseObj).
freeListObj := self objectAfter: trueObj.
self reInitializeClassTablePostLoad: (self objectAfter: freeListObj).
markStack := self swizzleObjStackAt: MarkStackRootIndex.
weaklingStack := self swizzleObjStackAt: WeaklingStackRootIndex.
ephemeronQueue := self swizzleObjStackAt: EphemeronQueueRootIndex.
+ self assert: self validObjStacks.
+ self assert: (self isEmptyObjStack: weaklingStack).
self initializeFreeSpacePostLoad: freeListObj.
segmentManager collapseSegmentsPostSwizzle.
self computeFreeSpacePostSwizzle.
self bootstrapping ifFalse:
[self initializeNewSpaceVariables].
self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart"
segmentManager checkSegments.
"These defaults should depend on machine size; e.g. too small on a powerful laptop, too big on a Pi."
growHeadroom := 16*1024*1024. "headroom when growing"
shrinkThreshold := 32*1024*1024. "free space before shrinking"!
Item was changed:
----- Method: SpurMemoryManager>>isEmptyObjStack: (in category 'obj stacks') -----
isEmptyObjStack: objStack
+ objStack = nilObj ifTrue:
+ [^true].
self assert: (self isValidObjStack: objStack).
+ ^0 = (self fetchPointer: ObjStackTopx ofObject: objStack)
+ and: [0 = (self fetchPointer: ObjStackNextx ofObject: objStack)]!
- ^0 = (self fetchPointer: ObjStackTopx ofObject: objStack)!
Item was added:
+ ----- Method: SpurMemoryManager>>isValidClassIndex: (in category 'class table') -----
+ isValidClassIndex: classIndex
+ | classTablePage |
+ classIndex <= 0 ifTrue:
+ [^false].
+ (classIndex <= self tagMask or: [classIndex >= self arrayClassIndexPun]) ifFalse:
+ [^false].
+ classIndex >= (1 << self classIndexFieldWidth) ifTrue:
+ [^false].
+ classTablePage := self fetchPointer: classIndex >> self classTableMajorIndexShift
+ ofObject: hiddenRootsObj.
+ classTablePage = nilObj ifTrue:
+ [^false].
+ (self addressCouldBeObj: classTablePage) ifFalse:
+ [false].
+ ^coInterpreter addressCouldBeClassObj:
+ (self
+ fetchPointer: (classIndex bitAnd: self classTableMinorIndexMask)
+ ofObject: classTablePage)!
Item was added:
+ ----- Method: SpurMemoryManager>>largeFreeChunkDistribution (in category 'compaction - analysis') -----
+ largeFreeChunkDistribution
+ "This method answers a sorted collection of the free chunks >= 1,000,000 bytes long,
+ sandwiched between nilObj and the end of memory (ignoring the large chunk often found at the end of the heap)."
+ <doNotGenerate>
+ | freeChunks |
+ freeChunks := SortedCollection new.
+ self allObjectsInFreeTreeDo:
+ [:f|
+ ((self addressAfter: f) < endOfMemory
+ and: [(self bytesInObject: f) >= 1000000]) ifTrue:
+ [freeChunks add: f]].
+ ^{{nilObj hex. #nil}}, (freeChunks collect: [:f| {f hex. self bytesInObject: f}]), {{endOfMemory hex. #endOfMemory}}!
Item was changed:
----- Method: SpurMemoryManager>>nilUnmarkedWeaklingSlots (in category 'weakness and ephemerality') -----
nilUnmarkedWeaklingSlots
"Nil the unmarked slots in the weaklings on the
weakling stack, finalizing those that lost references.
Finally, empty the weaklingStack."
<inline: false>
+ weaklingStack = nilObj ifTrue:
+ [^self].
self objStack: weaklingStack from: 0 do:
[:weakling|
(self nilUnmarkedWeaklingSlotsIn: weakling) ifTrue:
[coInterpreter signalFinalization: weakling]].
self emptyObjStack: weaklingStack!
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: (self addressOf: (segments at: i))
+ to: (i < (numSegments - 1) ifTrue: [self addressOf: (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: (self addressOf: (segments at: i))
+ to: (i < (numSegments - 1) ifTrue: [self addressOf: (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.
+ eventQueue := SharedQueue new.
suppressHeartbeatFlag := false.
systemAttributes := Dictionary new.
extSemTabSize := 256.
+ disableBooleanCheat := false!
- disableBooleanCheat := false.
-
- "Forward events from the host to the Simulator tty"
- eventQueue := SharedQueue new.!
Item was changed:
----- Method: StackInterpreterSimulator>>primitiveGetAttribute (in category 'other primitives') -----
primitiveGetAttribute
"Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."
| index s attribute |
index := self stackIntegerValue: 0.
self successful ifTrue: [
+ attribute := systemAttributes at: index ifAbsent: [Smalltalk vm getSystemAttribute: index].
- attribute := systemAttributes at: index ifAbsent: [Smalltalk getSystemAttribute: index].
attribute ifNil: [ ^self primitiveFail ].
s := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: attribute size.
1 to: attribute size do: [ :i |
objectMemory storeByte: i-1 ofObject: s withValue: (attribute at: i) asciiValue].
+ self pop: 2 "rcvr, attr" thenPush: s]!
- self pop: 2. "rcvr, attr"
- self push: s]!
Item was changed:
----- Method: StackInterpreterSimulator>>transcript (in category 'accessing') -----
transcript
+ ^transcript!
- "tty accessor needed by StackInstperpeterSimulatorMorphicModel"
- ^transcript!
Item was changed:
----- Method: StackInterpreterSimulator>>transcript: (in category 'accessing') -----
transcript: aTranscript
+ transcript := aTranscript!
- "tty accessor needed by StackInstperpeterSimulatorMorphicModel"
- transcript := aTranscript!
Item was added:
+ ----- Method: VMClass class>>initializationOptions (in category 'initialization') -----
+ initializationOptions
+ ^initializationOptions!
More information about the Vm-dev
mailing list