[Vm-dev] VM Maker: VMMaker.oscog-eem.454.mcz
commits at source.squeak.org
commits at source.squeak.org
Mon Oct 14 16:08:55 UTC 2013
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.454.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.454
Author: eem
Time: 14 October 2013, 9:03:57.157 am
UUID: a0291c46-546b-463d-90d2-ce37fd841eae
Ancestors: VMMaker.oscog-eem.453
Eliminate compilation errors from Spur interp.c:
Make Slang infer type of result of at: so that struct deref of e.g.
segments doesn't require a typed temp.
When inlining blocks rename and remember their labels so that if
multiple copies are inlined (as in Spur's allObjectsDo:) each copy
gets its own labels.
Remember structClasses in CCodeGenerator for emitCTypesOn:.
Filter-out initialize methods in addMethodFor:selector:.
Make VMClass>>initializeMiscConstants add
SqueakV3ObjectMemory to options if not Spur so that
primitiveRootTable[At] is excluded in Spur.
Make Slang emit if-then-else chains for caseOf:'s used in ifs (for
shouldBeTenured:). Needs nodesWithParentsDo:.
Declare the scavenger's space and remembered set inst vars.
Rename tenuringThreshold inst var to tenureThreshold to avoid
masking.
Ditto, rename some bytesInObject temps to bytesInObj.
Get return types of scavenger's space accessors right.
Add a shrinkThreshold inst var, but don't implement anything
meaningful yet.
Add SpurMemoryManager/SpurSegmentManager/
SpurGenerationScavenger translation support (declare vars,
ancilliary classes & implicit var names).
Replace some sends of class with sends of touch: (and sends of
touch with touch:).
Rename SpurSegmentInfo>start to segStart (avoids conflict).
Change scavengeReferentsOf: to cope with a forwarder to an
immediate created via becomeForward:.
Pass in tenuring criterion to scavenger as parameter of scavenge:.
Abstract the memory size vm parameters into
newSpaceSize, oldSpaceSize & totalMemorySize.
Simplify the various shouldGenerateTypedefFor: methods.
Neaten interp.h in writeVMHeaderTo:bytesPerWord:.
Turn off inlining of addTo[Weak|Ephemeron]List to neaten
copyAndForward:, and of freeObject: and objectAfter: for
initializeObjectMemory:.
Add forwardSurvivor:to: to avoid store check.
Change some var := expr ifTrue: [...] ifFalse: [...] to
expr ifTrue: [var := ...] ifFalse: [var := ...] to get past Slang limitations.
Eliminate some or:or: uses.
Eliminate comeFroms in scavenger simulator.
Slang:
Emit integers that look like bitmasks in hex.
Add declareCAsUSqLong: convenience.
Add nodesWithParentsDo: & nodesDo:parent:.
Rename cascadeVariableNumber to extraVariableNumber
to allow it to be used to derive the switchVariable for
if-then-else chaines caseOf:'s. buildSwitchStmt: =>
buildSwitchStmt:parent:.
=============== Diff against VMMaker.oscog-eem.453 ===============
Item was changed:
Object subclass: #CCodeGenerator
+ instanceVariableNames: 'vmClass structClasses translationDict asArgumentTranslationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods currentMethod headerFiles globalVariableUsage useSymbolicConstants generateDeadCode requiredSelectors logger suppressAsmLabels asmLabelCounts pools selectorTranslations optionsDictionary breakSrcInlineSelector breakDestInlineSelector'
- instanceVariableNames: 'vmClass translationDict asArgumentTranslationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods currentMethod headerFiles globalVariableUsage useSymbolicConstants generateDeadCode requiredSelectors logger suppressAsmLabels asmLabelCounts pools selectorTranslations optionsDictionary breakSrcInlineSelector breakDestInlineSelector'
classVariableNames: 'UseRightShiftForDivide'
poolDictionaries: 'VMBasicConstants'
category: 'VMMaker-Translation to C'!
!CCodeGenerator commentStamp: 'tpr 5/2/2003 14:30' prior: 0!
This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.
See VMMaker for more useful info!
Item was changed:
----- Method: CCodeGenerator>>addMethodFor:selector: (in category 'utilities') -----
addMethodFor: aClass selector: selector
"Add the given method to the code base and answer its translation
or nil if it shouldn't be translated."
| method tmethod |
+ selector == #initialize ifTrue:
+ [^nil].
method := aClass compiledMethodAt: selector.
(method pragmaAt: #doNotGenerate) ifNotNil:
[^nil].
"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."
(method pragmaAt: #option:) ifNotNil:
[:pragma| | key vmMaker |
key := pragma argumentAt: 1.
vmMaker := VMClass getVMMaker.
((Cogit withAllSubclasses anySatisfy: [:c| c name = key])
and: [vmMaker cogitClassName ~= key]) ifTrue:
[^nil].
(aClass bindingOf: key) ifNotNil:
[:binding|
binding value == false ifTrue: [^nil]].
(VMBasicConstants bindingOf: key) ifNotNil:
[:binding|
binding value == false ifTrue: [^nil]].
(vmMaker options at: key ifAbsent: []) ifNotNil:
[:option| option == false ifTrue: [^nil]]].
tmethod := self addMethod: (self compileToTMethodSelector: selector in: aClass).
"If the method has a macro then add the macro. But keep the method
for analysis purposes (e.g. its variable accesses)."
(method pragmaAt: #cmacro:) ifNotNil:
[:pragma|
self addMacro: (pragma argumentAt: 1) for: selector.
tmethod inline: false].
(method propertyValueAt: #cmacro:) ifNotNil:
[:macro|
self addMacro: macro for: selector.
tmethod inline: false].
^tmethod!
Item was added:
+ ----- Method: CCodeGenerator>>addStructClasses: (in category 'accessing') -----
+ addStructClasses: classes
+ "Add the struct classes and save them for emitCTypesOn: later."
+ structClasses := classes.
+ structClasses do:
+ [:structClass| self addStructClass: structClass]!
Item was changed:
----- Method: CCodeGenerator>>cLiteralFor: (in category 'C code generator') -----
cLiteralFor: anObject
"Return a string representing the C literal value for the given object."
anObject isNumber
ifTrue:
[anObject isInteger ifTrue:
+ [| printString |
+ printString := (anObject > 0
+ and: [(anObject >> anObject lowBit + 1) isPowerOfTwo
+ and: [anObject highBit - anObject lowBit >= 4]])
+ ifTrue: ['0x', (anObject printStringBase: 16)]
+ ifFalse: [anObject printString].
+ ^anObject > 16rFFFFFFFF
+ ifTrue: [printString, ObjectMemory unsignedLongLongSuffix]
- [^anObject > 16rFFFFFFFF
- ifTrue: [anObject printString , ObjectMemory unsignedLongLongSuffix]
ifFalse: [anObject < 16r7FFFFFFF
+ ifTrue: [printString]
+ ifFalse: [printString, ObjectMemory unsignedIntegerSuffix]]].
- ifTrue: [anObject printString]
- ifFalse: [anObject printString , ObjectMemory unsignedIntegerSuffix]]].
anObject isFloat ifTrue:
[^anObject printString]]
ifFalse:
[anObject isSymbol ifTrue:
[^self cFunctionNameFor: anObject].
anObject isString ifTrue:
[^'"', (anObject copyReplaceAll: (String with: Character cr) with: '\n') , '"'].
anObject == nil ifTrue: [^ 'null' ].
anObject == true ifTrue: [^ '1' ].
anObject == false ifTrue: [^ '0' ].
anObject isCharacter ifTrue:
[^anObject == $'
ifTrue: ['''\'''''] "i.e. '\''"
ifFalse: [anObject asString printString]]].
self error: 'Warning: A Smalltalk literal could not be translated into a C constant: ', anObject printString.
^'"XXX UNTRANSLATABLE CONSTANT XXX"'!
Item was changed:
----- Method: CCodeGenerator>>emitCTypesOn: (in category 'C code generator') -----
emitCTypesOn: aStream
"Store local type declarations on the given stream."
+ structClasses ifNotNil:
+ [structClasses do:
- vmClass ifNotNil:
- [(self structClassesForTranslationClasses: { vmClass }) do:
[:structClass|
(structClass isAbstract not
and: [vmClass shouldGenerateTypedefFor: structClass]) ifTrue:
[structClass printTypedefOn: aStream.
aStream cr; cr]]]!
Item was changed:
----- Method: CCodeGenerator>>generateValue:on:indent: (in category 'C translation') -----
generateValue: aTSendNode on: aStream indent: level
"Reduce [:formal ... :formalN| body ] value: actual ... value: actualN
to body with formals substituted for by actuals."
+ | substitution substitutionDict newLabels |
- | substitution substitutionDict |
self assert: aTSendNode receiver isStmtList.
self assert: aTSendNode receiver args size = aTSendNode args size.
substitution := aTSendNode receiver copy.
+ substitution renameLabelsForInliningInto: currentMethod.
substitutionDict := Dictionary new: aTSendNode args size * 2.
aTSendNode receiver args with: aTSendNode args do:
[ :argName :exprNode |
substitutionDict at: argName put: exprNode].
substitution
bindVariablesIn: substitutionDict;
+ emitCCodeOn: aStream level: level generator: self.
+ newLabels := Set withAll: currentMethod labels.
+ substitution nodesDo:
+ [:node| node isLabel ifTrue: [node label ifNotNil: [:label| newLabels add: label]]].
+ "now add the new labels so that a subsequent inline of
+ the same block will be renamed with different labels."
+ currentMethod labels: newLabels!
- emitCCodeOn: aStream level: level generator: self!
Item was added:
+ ----- Method: CCodeGenerator>>nonStructClassesForTranslationClasses: (in category 'utilities') -----
+ nonStructClassesForTranslationClasses: classes
+ "Answer in superclass order (any superclass precedes any subclass)
+ the ancilliaryClasses that are not struct classes for all the given classes."
+ | nonStructClasses |
+ nonStructClasses := OrderedCollection new.
+ classes do:
+ [:aTranslationClass|
+ ([aTranslationClass ancilliaryClasses: self options]
+ on: MessageNotUnderstood
+ do: [:ex|
+ ex message selector == #ancilliaryClasses:
+ ifTrue: [#()]
+ ifFalse: [ex pass]]) do:
+ [:class|
+ (class isStructClass
+ or: [(nonStructClasses includes: class)
+ or: [classes includes: class]]) ifFalse:
+ [nonStructClasses addLast: class]]].
+ ^ChangeSet superclassOrder: nonStructClasses!
Item was added:
+ ----- Method: CCodeGenerator>>structClasses (in category 'accessing') -----
+ structClasses
+ ^structClasses!
Item was added:
+ ----- Method: CCodeGenerator>>structClasses: (in category 'accessing') -----
+ structClasses: classes
+ structClasses := classes.
+ structClasses do:
+ [:structClass| self addStructClass: structClass]!
Item was changed:
+ ----- Method: CCodeGenerator>>vmClass (in category 'accessing') -----
- ----- Method: CCodeGenerator>>vmClass (in category 'public') -----
vmClass
+ "Answer the interpreter class if any. This is nil other than for the core VM."
- "Answer the interpreter classs if any. This is nil other than for the core VM."
^vmClass!
Item was changed:
+ ----- Method: CCodeGenerator>>vmClass: (in category 'accessing') -----
- ----- Method: CCodeGenerator>>vmClass: (in category 'public') -----
vmClass: aClass
"Set the interpreter class if any. This is nil other than for the core VM."
vmClass := aClass!
Item was changed:
----- Method: CoInterpreter class>>shouldGenerateTypedefFor: (in category 'translation') -----
shouldGenerateTypedefFor: aStructClass
"Hack to work-around multiple definitions. Sometimes a type has been defined in an include."
+ ^(super shouldGenerateTypedefFor: aStructClass)
+ and: [Cogit shouldGenerateTypedefFor: aStructClass]!
- ^({ CogBlockMethod. CogMethod. NewspeakCogMethod. SistaCogMethod. VMCallbackContext } includes: aStructClass) not!
Item was changed:
----- Method: CoInterpreter class>>writeVMHeaderTo:bytesPerWord: (in category 'translation') -----
writeVMHeaderTo: aStream bytesPerWord: bytesPerWord
super writeVMHeaderTo: aStream bytesPerWord: bytesPerWord.
aStream
nextPutAll: '#define COGVM 1'; cr;
nextPutAll: '#if !!defined(COGMTVM)'; cr;
nextPutAll: '# define COGMTVM 0'; cr;
+ nextPutAll: '#endif'; cr!
- nextPutAll: '#endif'; cr; cr!
Item was changed:
----- Method: CoInterpreterMT class>>writeVMHeaderTo:bytesPerWord: (in category 'translation') -----
writeVMHeaderTo: aStream bytesPerWord: bytesPerWord
super writeVMHeaderTo: aStream bytesPerWord: bytesPerWord.
+ aStream cr.
((VMBasicConstants classPool associations select: [:a| a key beginsWith: 'DisownVM'])
asSortedCollection: [:a1 :a2| a1 value <= a2 value])
do: [:a|
+ aStream nextPutAll: '#define '; nextPutAll: a key; space; print: a value; cr]!
- aStream nextPutAll: '#define '; nextPutAll: a key; space; print: a value; cr].
- aStream cr!
Item was changed:
----- Method: CoInterpreterPrimitives>>pathTo:using:followWeak: (in category 'object access primitives') -----
pathTo: goal using: stack followWeak: followWeak
"Trace objects and frames from the root, marking visited objects, pushing the current path on stack, until goal is found.
If found, unmark, leaving path in stack, and answer 0. Otherwise answer an error:
PrimErrBadArgument if stack is not an Array
PrimErrBadIndex if search overflows stack
PrimErrNotFound if goal cannot be found"
| current hdr index next stackSize stackp freeStartAtStart |
(objectMemory isArray: stack) ifFalse:
[^PrimErrBadArgument].
freeStartAtStart := objectMemory freeStart. "check no allocations during search"
objectMemory beRootIfOld: stack. "so no store checks are necessary on stack"
stackSize := objectMemory lengthOf: stack.
objectMemory mark: stack.
"no need. the current context is not reachable from the active process (suspendedContext is nil)"
"objectMemory mark: self activeProcess."
current := objectMemory specialObjectsOop.
objectMemory mark: current.
index := objectMemory lengthOf: current.
stackp := 0.
[[(index := index - 1) >= -1] whileTrue:
+ [(stackPages couldBeFramePointer: current)
+ ifTrue:
+ [next := index >= 0
- [next := (stackPages couldBeFramePointer: current)
- ifTrue:
- [index >= 0
ifTrue: [self field: index ofFrame: (self cCoerceSimple: current to: #'char *')]
ifFalse: [objectMemory nilObject]]
+ ifFalse:
+ [index >= 0
+ ifTrue:
+ [hdr := objectMemory baseHeader: current.
+ next := (objectMemory isContextHeader: hdr)
- ifFalse:
- [index >= 0
- ifTrue:
- [hdr := objectMemory baseHeader: current.
- (objectMemory isContextHeader: hdr)
ifTrue: [self fieldOrSenderFP: index ofContext: current]
ifFalse: [objectMemory fetchPointer: index ofObject: current]]
+ ifFalse:
+ [next := objectMemory fetchClassOfNonImm: current]].
- ifFalse:
- [objectMemory fetchClassOfNonImm: current]].
(stackPages couldBeFramePointer: next)
ifTrue: [self assert: (self isFrame: (self cCoerceSimple: next to: #'char *')
onPage: (stackPages stackPageFor: (self cCoerceSimple: next to: #'char *')))]
ifFalse:
[next >= heapBase ifTrue:
[self assert: (self checkOkayOop: next)]].
next = goal ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory storePointer: stackp ofObject: stack withValue: current.
self pruneStack: stack stackp: stackp.
^0].
((objectMemory isNonIntegerObject: next)
and: [(stackPages couldBeFramePointer: next)
ifTrue: [(self frameIsMarked: next) not]
ifFalse:
[next >= heapBase "exclude Cog methods"
and: [(objectMemory isMarked: next) not
and: [((objectMemory isPointers: next) or: [objectMemory isCompiledMethod: next])
and: [followWeak or: [(objectMemory isWeakNonImm: next) not]]]]]])
ifTrue:
[stackp + 2 > stackSize ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory nilFieldsOf: stack.
^PrimErrBadIndex]. "PrimErrNoMemory ?"
objectMemory
storePointerUnchecked: stackp ofObject: stack withValue: current;
storePointerUnchecked: stackp + 1 ofObject: stack withValue: (objectMemory integerObjectOf: index).
stackp := stackp + 2.
(stackPages couldBeFramePointer: (self cCoerceSimple: next to: #'char *'))
ifTrue:
[self markFrame: next.
index := self fieldsInFrame: (self cCoerceSimple: next to: #'char *')]
ifFalse:
[hdr := objectMemory baseHeader: next.
objectMemory baseHeader: next put: (hdr bitOr: MarkBit).
(objectMemory isCompiledMethodHeader: hdr)
ifTrue: [index := (self literalCountOf: next) + LiteralStart]
ifFalse: [index := objectMemory lengthOf: next]].
current := next]].
current = objectMemory specialObjectsOop ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory nilFieldsOf: stack.
^PrimErrNotFound].
index := objectMemory integerValueOf: (objectMemory fetchPointer: stackp - 1 ofObject: stack).
current := objectMemory fetchPointer: stackp - 2 ofObject: stack.
stackp := stackp - 2] repeat!
Item was changed:
----- Method: CogARMCompiler>>isPCDependent (in category 'testing') -----
isPCDependent
"Answer if the receiver is a pc-dependent instruction."
+ ^self isJump or: [opcode = AlignmentNops or: [opcode = Call]]!
- ^self isJump or: [opcode = AlignmentNops] or: [opcode = Call]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveRootTable (in category 'memory space primitives') -----
primitiveRootTable
"Primitive. Answer a copy (snapshot) element of the root table.
The primitive can cause GC itself and if so the return value may
be inaccurate - in this case one should guard the read operation
by looking at the gc counter statistics."
+ <option: #SqueakV3ObjectMemory>
self pop: argumentCount + 1 thenPush: objectMemory rootTableObject!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveRootTableAt (in category 'memory space primitives') -----
primitiveRootTableAt
"Primitive. Answer the nth element of the root table.
This primitive avoids the creation of an extra array;
it is intended for enumerations of the form:
index := 1.
[root := Smalltalk rootTableAt: index.
root == nil] whileFalse:[index := index + 1].
"
- | index |
<export: true>
+ <option: #SqueakV3ObjectMemory>
+ | index |
index := self stackIntegerValue: 0.
self success: (index > 0 and:[index <= objectMemory rootTableCount]).
self successful ifTrue:[
self pop: argumentCount + 1.
self push: (objectMemory rootTable at: index).
]!
Item was added:
+ ----- Method: NewObjectMemory>>newSpaceSize (in category 'accessing') -----
+ newSpaceSize
+ ^freeStart - self startOfMemory!
Item was removed:
- ----- Method: NewspeakInterpreter class>>shouldGenerateTypedefFor: (in category 'translation') -----
- shouldGenerateTypedefFor: aStructClass
- "Hack to work-around mutliple definitions. Sometimes a type has been defined in an include."
- ^aStructClass ~~ VMCallbackContext!
Item was removed:
- ----- Method: NewsqueakIA32ABIPlugin class>>shouldGenerateTypedefFor: (in category 'translation') -----
- shouldGenerateTypedefFor: aStructClass
- "Hack to work-around mutliple definitions. Sometimes a type has been defined in an include."
- ^aStructClass ~~ VMCallbackContext!
Item was changed:
----- Method: ObjectMemory class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
aCCodeGenerator
var: #memory
declareC: 'static usqInt memory'.
aCCodeGenerator
var: #remapBuffer
declareC: 'sqInt remapBuffer[RemapBufferSize + 1 /* ', (RemapBufferSize + 1) printString, ' */]'.
aCCodeGenerator
var: #rootTable
declareC: 'sqInt rootTable[RootTableSize + 1 /* ', (RootTableSize + 1) printString, ' */]'.
"Weak roots must be large enough for roots+remapBuffer+sizeof(allCallsOn: #markAndTrace:)"
aCCodeGenerator
var: #weakRoots
declareC: 'sqInt weakRoots[WeakRootTableSize + 1 /* ', (WeakRootTableSize + 1) printString, ' */]'.
aCCodeGenerator
var: #headerTypeBytes
declareC: 'sqInt headerTypeBytes[4]'.
aCCodeGenerator
var: #extraRoots
declareC: 'sqInt* extraRoots[ExtraRootSize + 1 /* ', (ExtraRootSize + 1) printString, ' */]'.
self declareCAsOop: {
#youngStart .
#endOfMemory .
#memoryLimit .
#youngStartLocal .
#freeBlock .
#compStart .
#compEnd .
#fwdTableNext .
#fwdTableLast .
#gcBiasToGrowThreshold }
in: aCCodeGenerator.
aCCodeGenerator
var: #headerTypeBytes type: 'const sqInt' array: HeaderTypeExtraBytes.
+ self declareCAsUSqLong: #(gcStartUsecs statFullGCUsecs statIncrGCUsecs statIGCDeltaUsecs)
- self declareC: #(gcStartUsecs statFullGCUsecs statIncrGCUsecs statIGCDeltaUsecs)
- as: #usqLong
in: aCCodeGenerator!
Item was added:
+ ----- Method: ObjectMemory>>newSpaceSize (in category 'accessing') -----
+ newSpaceSize
+ ^freeBlock - self startOfMemory!
Item was added:
+ ----- Method: ObjectMemory>>oldSpaceSize (in category 'accessing') -----
+ oldSpaceSize
+ ^youngStart - self startOfMemory!
Item was added:
+ ----- Method: ObjectMemory>>totalMemorySize (in category 'accessing') -----
+ totalMemorySize
+ ^endOfMemory - self startOfMemory!
Item was changed:
----- Method: RiscOSVMMaker>>needsToRegenerateInterpreterFile (in category 'initialize') -----
needsToRegenerateInterpreterFile
"check the timestamp for the relevant classes and then the timestamp for the interp.c file if it already exists. Return true if the file needs regenerating, false if not"
| tStamp fstat |
tStamp := (self interpreterClass withAllSuperclasses copyUpTo: ObjectMemory superclass),
+ (self interpreterClass ancilliaryClasses: self options)
- self interpreterClass ancilliaryClasses
inject: 0 into: [:tS :cl| tS max: cl timeStamp].
"don't translate if the file is newer than my timeStamp"
"RiscOS keeps the interp file in a 'c' subdirectory of coreVMDirectory"
(self coreVMDirectory directoryExists: 'c') ifFalse:[^true].
fstat := (self coreVMDirectory directoryNamed: 'c') entryAt: self interpreterFilename ifAbsent:[nil].
fstat ifNotNil:[tStamp < fstat modificationTime ifTrue:[^false]].
^true
!
Item was changed:
----- Method: Spur32BitMemoryManager>>allocateNewSpaceSlots:format:classIndex: (in category 'allocation') -----
allocateNewSpaceSlots: numSlots format: formatField classIndex: classIndex
+ "Allocate an object with numSlots in newSpace. This is for the `ee' execution engine allocations,
+ and must be satisfied. If no memory is available, abort."
| numBytes newObj |
"Object headers are 8 bytes in length if the slot size fits in the num slots field (max implies overflow),
16 bytes otherwise (num slots in preceeding word).
Objects always have at least one slot, for the forwarding pointer,
and are multiples of 8 bytes in length."
numSlots >= self numSlotsMask
ifTrue:
[newObj := freeStart + self baseHeaderSize.
numBytes := self baseHeaderSize + self baseHeaderSize "double header"
+ (numSlots + (numSlots bitAnd: 1) * self bytesPerSlot)] "roundTo allocationUnit"
ifFalse:
[newObj := freeStart.
numBytes := self baseHeaderSize "single header"
+ (numSlots <= 1
ifTrue: [self allocationUnit] "at least one slot for the forwarding pointer"
ifFalse: [numSlots + (numSlots bitAnd: 1) * self bytesPerSlot])]. "roundTo allocationUnit"
freeStart + numBytes > scavengeThreshold ifTrue:
[needGCFlag ifFalse: [self scheduleScavenge].
freeStart + numBytes > scavenger eden limit ifTrue:
+ [self error: 'no room in eden for allocateNewSpaceSlots:format:classIndex:'.
+ ^0]].
- [^self error: 'no room in eden for allocateNewSpaceSlots:format:classIndex:']].
numSlots >= self numSlotsMask
ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word"
[self flag: #endianness.
self longAt: freeStart put: numSlots.
self longAt: freeStart + 4 put: self numSlotsMask << self numSlotsHalfShift.
self longLongAt: newObj put: (self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex)]
ifFalse:
[self longLongAt: newObj put: (self headerForSlots: numSlots format: formatField classIndex: classIndex)].
self assert: numBytes \\ self allocationUnit = 0.
self assert: newObj \\ self allocationUnit = 0.
freeStart := freeStart + numBytes.
^newObj!
Item was changed:
----- Method: Spur64BitMemoryManager>>allocateNewSpaceSlots:format:classIndex: (in category 'allocation') -----
allocateNewSpaceSlots: numSlots format: formatField classIndex: classIndex
+ "Allocate an object with numSlots in newSpace. This is for the `ee' execution engine allocations,
+ and must be satisfied. If no memory is available, abort."
| numBytes newObj |
"Object headers are 8 bytes in length if the slot size fits in the num slots field (max implies overflow),
16 bytes otherwise (num slots in preceeding word).
Objects always have at least one slot, for the forwarding pointer,
and are multiples of 8 bytes in length."
numSlots >= self numSlotsMask
ifTrue:
[numSlots > 16rffffffff ifTrue:
[^nil].
newObj := freeStart + self baseHeaderSize.
numBytes := (self baseHeaderSize + self baseHeaderSize) "double header"
+ (numSlots * self bytesPerSlot)]
ifFalse:
[newObj := freeStart.
numBytes := self baseHeaderSize "single header"
+ (numSlots < 1
ifTrue: [self allocationUnit] "at least one slot for the forwarding pointer"
ifFalse: [numSlots * self bytesPerSlot])].
freeStart + numBytes > scavengeThreshold ifTrue:
[needGCFlag ifFalse: [self scheduleScavenge].
freeStart + numBytes > scavenger eden limit ifTrue:
+ [self error: 'no room in eden for allocateNewSpaceSlots:format:classIndex:'.
+ ^0]].
- [^self error: 'no room in eden for allocateNewSpaceSlots:format:classIndex:']].
numSlots >= self numSlotsMask
ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word"
[self flag: #endianness.
self longAt: freeStart put: numSlots.
self longAt: freeStart + 4 put: self numSlotsMask << self numSlotsHalfShift.
self longLongAt: newObj put: (self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex)]
ifFalse:
[self longLongAt: newObj put: (self headerForSlots: numSlots format: formatField classIndex: classIndex)].
self assert: numBytes \\ self allocationUnit = 0.
self assert: newObj \\ self allocationUnit = 0.
freeStart := freeStart + numBytes.
^newObj!
Item was changed:
CogClass subclass: #SpurGenerationScavenger
+ instanceVariableNames: 'coInterpreter manager eden futureSpace pastSpace futureSurvivorStart rememberedSet rememberedSetSize previousRememberedSetSize weakList ephemeronList tenureCriterion tenureThreshold tenuringClassIndex tenuringProportion numRememberedEphemerons'
- instanceVariableNames: 'coInterpreter manager eden futureSpace pastSpace futureSurvivorStart rememberedSet rememberedSetSize previousRememberedSetSize weakList ephemeronList tenuringCriterion tenuringThreshold tenuringClassIndex tenuringProportion numRememberedEphemerons'
classVariableNames: 'RememberedSetLimit RememberedSetRedZone'
poolDictionaries: 'SpurMemoryManagementConstants'
category: 'VMMaker-SpurMemoryManager'!
!SpurGenerationScavenger commentStamp: 'eem 9/30/2013 11:05' prior: 0!
SpurGenerationScavenger is an implementation of David Ungar's Generation Scavenging garbage collection algorithm. See
Generation Scavenging, A Non-disruptive, High-Performance Storage Reclamation Algorithm
David Ungar
Proceeding
SDE 1 Proceedings of the first ACM SIGSOFT/SIGPLAN software engineering symposium on Practical software development environments
Pages 157 - 167
ACM New York, NY, USA ©1984
Also relevant are
An adaptive tenuring policy for generation scavengers
David Ungar & Frank Jackson
ACM Transactions on Programming Languages and Systems (TOPLAS) TOPLAS Homepage archive
Volume 14 Issue 1, Jan. 1992
Pages 1 - 27
ACM New York, NY, USA ©1992
and
Ephemerons: a new finalization mechanism
Barry Hayes
Proceedings of the 12th ACM SIGPLAN conference on Object-oriented programming, systems, languages, and applications
Pages 176-183
ACM New York, NY, USA ©1997
See text below the variable definitions and explanation below for a full explanation of weak and ephemeron processing.
Instance Variables
coInterpreter: <StackInterpreterSimulator|CogVMSimulator>
eden: <SpurNewSpaceSpace>
ephemeronList: <Integer|nil>
futureSpace: <SpurNewSpaceSpace>
futureSurvivorStart: <Integer address>
manager: <SpurMemoryManager|Spur32BitMMLESimulator et al>
numRememberedEphemerons: <Integer>
pastSpace: <SpurNewSpaceSpace>
previousRememberedSetSize: <Integer>
rememberedSet: <CArrayAccessor on: Array>
rememberedSetSize: <Integer>
tenuringProportion: <Float>
tenuringThreshold: <Integer address>
weakList: <Integer|nil>
coInterpreter
- the interpreter/vm, in this context, the mutator
manager
- the Spur memory manager
eden
- the space containing newly created objects
futureSpace
- the space to which surviving objects are copied during a scavenge
futureSurvivorStart
- the allocation pointer into futureSpace
pastSpace
- the space surviving objects live in until the next scavenge
rememberedSet
- the root old space objects that refer to objects in new space; a scavenge starts form these roots and the interpreter's stack
rememberedSetSize
- the size of the remembered set, also the first unused index in the rememberedSet
previousRememberedSetSize:
- the size of the remembered set before scavenging objects in future space.
numRememberedEphemerons
- the number of unscavenged ephemerons at the front of the rememberedSet.
ephemeronList
- the head of the list of corpses of unscavenged ephemerons reached in the current phase
weakList
- the head of the list of corpses of weak arrays reached during the scavenge.
tenuringProportion
- the amount of pastSpace below which the system will not tenure unless futureSpace fills up, and above which it will eagerly tenure
tenuringThreshold
- the pointer into pastSpace below which objects will be tenured
Weakness and Ephemerality in the Scavenger.
Weak arrays should not hold onto their referents (except from their strong fileds, their named inst vars). Ephemerons are objects that implement instance-based finalization; attaching an ephemeron to an object keeps that object alive and causes the ephemeron to "fire" when the object is only reachable from the ephemeron (or other ephemerons & weak arrays). They are a special kind of Associations that detect when their keys are about to die, i.e. when an ephemeron's key is not reachable from the roots except from weak arrays and other ephemerons with about-to-die keys. Note that if an ephemeron's key is not about to die then references from the rest of the ephemeron can indeed prevent ephemeron keys from dying.
The scavenger is concerned with collecting objects in new space, therefore it ony deals with weak arrays and ephemerons that are either in the remembered set or in new space. By deferring scanning these objects until other reachable objects have been scavenged, the scavenger can detect dead or dying references.
Weak Array Processing
In the case of weak arrays this is simple. The scavenger refuses to scavenge the referents of weak arrays in scavengeReferentsOf: until the entire scavenge is over. It then scans the weak arrays in the remembered set and in future space and nils all fields in them that are referring to unforwarded objects in eden and past space, because these objects have not survived the scavenge. The root weak arrays remaining to be scavenged are in the remembered table. Surviving weak arrays in future space are collected on a list. The list is threaded through the corpses of weak arrays in eden and/or past space. weakList holds the slot offset of the first weak array found in eden and/or past space. The next offset is stored in the weak array corpse's identityHash and format fields (22 bits & 5 bits of allocationUnits, for a max new space size of 2^28 bytes, 256Mb). The list is threaded throguh corpses, but the surviving arrays are pointed to by the corpses' forwarding pointers.
Ephemeron Processing
The case of ephemerons is a little more complicated because an ephemeron's key should survive. The scavenger is cyclical. It scavenges the remembered set, which may copy and forward surviving objects in past and/or eden spaces to future space. It then scavenges those promoted objects in future space until no more are promoted, which may in turn remember more objects. The cycles continue until no more objects get promoted to future space and no more objects get remembered. At this point all surviving objecta are in futureSpace.
So if the scavenger does not scan ephemerons in the remembered set or in future space until the scavenger finishes cycling, it can detect ephemerons whose keys are about to die because these will be unforwarded objects in eden and/or past space. Ephemerons encountered in the remembered set are either processed like ordinary objects if their keys have been promoted to futureSpace, or are moved to the front of the rememberedSet (because, dear reader, it is a sequence) if their keys have not been promoted. Ephemerons encountered in scavengeReferentsOf: are either scanned like normal objects if their keys have been promoted, or added to the ephemeronList, organized identically to the weakList, if their keys are yet to be promoted. Since references from other ephemerons with surviving keys to ephemeron keys can and should prevent the ephemerons whose keys they are from firing the scavenger does not fire ephemerons unless all unscavenged ephemerons have unscavenged keys. So the unscavenged ephemerons (the will be at the beginning of the remembered set and on the ephemeronList) are scanned and any that have promoted keys are scavenged. But if no unscavenged ephemerons have surviving keys then all the unscavenged ephemerons are fired and then scavenged. This in turn may remember more objects and promote more objects to future space, and encounter more unscavenged ephemerons. So the scavenger continues until no more objects are remembered, no more objects are promoted to future space and no more unscavenged ephemerons exist.!
Item was added:
+ ----- Method: SpurGenerationScavenger class>>declareCVarsIn: (in category 'translation') -----
+ declareCVarsIn: aCCodeGenerator
+ #(eden futureSpace pastSpace) do:
+ [:var| aCCodeGenerator var: var type: #SpurNewSpaceSpace].
+ aCCodeGenerator
+ var: #rememberedSet
+ declareC: 'sqInt rememberedSet[RememberedSetLimit + 1 /* ', (RememberedSetLimit + 1) printString, ' */]'!
Item was added:
+ ----- Method: SpurGenerationScavenger class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') -----
+ isNonArgumentImplicitReceiverVariableName: instVarName
+ ^#('self' 'coInterpreter' 'manager') includes: instVarName!
Item was changed:
----- Method: SpurGenerationScavenger>>addToEphemeronList: (in category 'weakness and ephemerality') -----
addToEphemeronList: ephemeronCorpse
"ephemeronCorpse is the corpse of an ephemeron that was copied and forwarded.
Later on its surviving copy must be scanned to nil weak references.
Thread the corpse onto the weakList. Later, the weakList can be followed, and
the forwarding pointer followed to locate the survivor."
+ <inline: false>
| ephemeronListOffset |
self assert: (manager isYoung: ephemeronCorpse).
self assert: (manager isForwarded: ephemeronCorpse).
self assert: (self isScavengeSurvivor: (manager keyOfEphemeron: (manager followForwarded: ephemeronCorpse))) not.
ephemeronListOffset := ephemeronList ifNil: 0.
self setCorpseOffsetOf: ephemeronCorpse to: ephemeronListOffset.
ephemeronList := self corpseOffsetOf: ephemeronCorpse.
self assert: (self firstCorpse: ephemeronList) = ephemeronCorpse!
Item was changed:
----- Method: SpurGenerationScavenger>>addToWeakList: (in category 'weakness and ephemerality') -----
addToWeakList: weakCorpse
"weakCorpse is the corpse of a weak array that was copied and forwarded.
Later on its surviving copy must be scanned to nil weak references.
Thread the corpse onto the weakList. Later, the weakList can be followed, and
the forwarding pointer followed to locate the survivor."
+ <inline: false>
| weakListOffset |
self assert: (manager isYoung: weakCorpse).
self assert: (manager isForwarded: weakCorpse).
weakListOffset := weakList ifNil: 0.
self setCorpseOffsetOf: weakCorpse to: weakListOffset.
weakList := self corpseOffsetOf: weakCorpse.
self assert: (self firstCorpse: weakList) = weakCorpse!
Item was changed:
----- Method: SpurGenerationScavenger>>computeTenuringThreshold (in category 'scavenger') -----
computeTenuringThreshold
| fractionSurvived |
<var: 'fractionSurvived' type: #float>
fractionSurvived := futureSpace limit = futureSpace start
ifTrue:
[0.0]
ifFalse:
[(futureSurvivorStart - futureSpace start) asFloat
/ (futureSpace limit - futureSpace start)].
+ tenureThreshold := fractionSurvived > 0.9
- tenuringThreshold := fractionSurvived > 0.9
ifTrue: [((pastSpace limit - pastSpace start) * (1.0 - tenuringProportion)) rounded + pastSpace start]
ifFalse: [0]!
Item was changed:
----- Method: SpurGenerationScavenger>>copyAndForward: (in category 'scavenger') -----
copyAndForward: survivor
"copyAndForward: survivor copies a survivor object either to
futureSurvivorSpace or, if it is to be promoted, to oldSpace.
It leaves a forwarding pointer behind. If the object is weak
then corpse is threaded onto the weakList for later treatment."
+ <inline: false>
+ | bytesInObj newLocation hash |
+ self assert: survivor >= manager startOfMemory. "cog methods should be excluded."
+ bytesInObj := manager bytesInObject: survivor.
- <inline: true>
- | bytesInObject newLocation hash |
- bytesInObject := manager bytesInObject: survivor.
"Must remember hash before copying because threading
on to the weak & ephemeron lists smashes the hash field."
hash := manager rawHashBitsOf: survivor.
((self shouldBeTenured: survivor)
+ or: [futureSurvivorStart + bytesInObj > futureSpace limit])
- or: [futureSurvivorStart + bytesInObject > futureSpace limit])
ifTrue:
[newLocation := self copyToOldSpace: survivor.
+ manager forwardSurvivor: survivor to: newLocation]
- manager forward: survivor to: newLocation]
ifFalse:
+ [newLocation := self copyToFutureSpace: survivor bytes: bytesInObj.
+ manager forwardSurvivor: survivor to: newLocation.
- [newLocation := self copyToFutureSpace: survivor bytes: bytesInObject.
- manager forward: survivor to: newLocation.
"if weak or ephemeron add to the relevant lists if newLocation is young. If
old, newLocation will be remembered and dealt with in the rememberedSet."
(manager isWeakNonImm: newLocation) ifTrue:
[self addToWeakList: survivor].
((manager isEphemeron: newLocation)
and: [(self isScavengeSurvivor: (manager keyOfEphemeron: newLocation)) not]) ifTrue:
[self addToEphemeronList: survivor]].
hash ~= 0 ifTrue:
[manager setHashBitsOf: newLocation to: hash].
^newLocation!
Item was changed:
----- Method: SpurGenerationScavenger>>eden (in category 'accessing') -----
eden
+ <returnTypeC: #SpurNewSpaceSpace>
+ <cmacro: '() GIV(eden)'>
+ ^eden!
- <returnTypeC: #'SpurNewSpaceSpace *'>
- ^self addressOf: eden!
Item was changed:
----- Method: SpurGenerationScavenger>>exchangeSurvivorSpaces (in category 'scavenger') -----
exchangeSurvivorSpaces
| temp |
+ <var: #temp type: #SpurNewSpaceSpace>
temp := pastSpace.
pastSpace := futureSpace.
futureSpace := temp!
Item was changed:
----- Method: SpurGenerationScavenger>>futureSpace (in category 'accessing') -----
futureSpace
+ <returnTypeC: #SpurNewSpaceSpace>
+ <cmacro: '() GIV(futureSpace)'>
+ ^futureSpace!
- <returnTypeC: #'SpurNewSpaceSpace *'>
- ^self addressOf: futureSpace!
Item was changed:
----- Method: SpurGenerationScavenger>>getRawTenuringThreshold (in category 'accessing') -----
getRawTenuringThreshold
+ ^tenureThreshold!
- ^tenuringThreshold!
Item was changed:
----- Method: SpurGenerationScavenger>>initialize (in category 'initialization') -----
initialize
pastSpace := SpurNewSpaceSpace new.
futureSpace := SpurNewSpaceSpace new.
eden := SpurNewSpaceSpace new.
rememberedSet := CArrayAccessor on: (Array new: RememberedSetLimit).
rememberedSetSize := 0.
+ tenureThreshold := 0.
- tenuringThreshold := 0.
tenuringProportion := 0.9!
Item was changed:
----- Method: SpurGenerationScavenger>>isScavengeSurvivor: (in category 'weakness and ephemerality') -----
isScavengeSurvivor: oop
"Answer whether the oop has survived a scavenge. This is equivalent to
| target |
(manager isImmediate: oop) ifTrue:
[^true].
target := (manager isForwarded: oop)
ifTrue: [manager followForwarded: oop]
ifFalse: [oop].
^((manager isInEden: target)
or: [(manager isInPastSpace: target)]) not"
| target |
(manager isImmediate: oop) ifTrue:
[^true].
+ (manager isForwarded: oop)
+ ifTrue: [target := manager followForwarded: oop]
+ ifFalse: [target := oop].
- target := (manager isForwarded: oop)
- ifTrue: [manager followForwarded: oop]
- ifFalse: [oop].
^(manager isYoung: target) not
or: [manager isInFutureSpace: target]!
Item was added:
+ ----- Method: SpurGenerationScavenger>>newSpaceCapacity (in category 'accessing') -----
+ newSpaceCapacity
+ ^eden limit - (futureSpace start min: pastSpace start)!
Item was changed:
----- Method: SpurGenerationScavenger>>newSpaceStart:newSpaceBytes:edenBytes: (in category 'initialization') -----
newSpaceStart: startAddress newSpaceBytes: totalBytes edenBytes: requestedEdenBytes
| edenBytes survivorBytes |
edenBytes := requestedEdenBytes.
survivorBytes := totalBytes - edenBytes // 2 truncateTo: manager allocationUnit.
edenBytes := totalBytes - survivorBytes - survivorBytes truncateTo: manager allocationUnit.
self assert: totalBytes - edenBytes - survivorBytes - survivorBytes < manager allocationUnit.
"for tenuring we require older objects below younger objects. since allocation
grows up this means that the survivor spaces must preceed eden."
+ pastSpace start: startAddress; limit: startAddress + survivorBytes.
+ futureSpace start: pastSpace limit; limit: pastSpace limit + survivorBytes.
+ eden start: futureSpace limit; limit: futureSpace limit + edenBytes.
- pastSpace start: startAddress limit: startAddress + survivorBytes.
- futureSpace start: pastSpace limit limit: pastSpace limit + survivorBytes.
- eden start: futureSpace limit limit: futureSpace limit + edenBytes.
self assert: futureSpace limit <= (startAddress + totalBytes).
self assert: eden start \\ manager allocationUnit
+ (eden limit \\ manager allocationUnit) = 0.
self assert: pastSpace start \\ manager allocationUnit
+ (pastSpace limit \\ manager allocationUnit) = 0.
self assert: futureSpace start \\ manager allocationUnit
+ (futureSpace limit \\ manager allocationUnit) = 0.
self initFutureSpaceStart.
+ manager initSpaceForAllocationCheck: (self addressOf: eden)!
- manager initSpaceForAllocationCheck: eden!
Item was changed:
----- Method: SpurGenerationScavenger>>pastSpace (in category 'accessing') -----
pastSpace
+ <returnTypeC: #SpurNewSpaceSpace>
+ <cmacro: '() GIV(pastSpace)'>
+ ^pastSpace!
- <returnTypeC: #'SpurNewSpaceSpace *'>
- ^self addressOf: pastSpace!
Item was changed:
----- Method: SpurGenerationScavenger>>rememberedSetSize (in category 'accessing') -----
rememberedSetSize
+ <cmacro: '() GIV(rememberedSetSize)'>
^rememberedSetSize!
Item was removed:
- ----- Method: SpurGenerationScavenger>>scavenge (in category 'scavenger') -----
- scavenge
- "The main routine, scavenge, scavenges young objects reachable from the roots (the stack zone
- and the rememberedTable). It first scavenges the new objects immediately reachable from old
- ones (all in the remembered table), then the stack zone. Then it scavenges those that are
- transitively reachable. If this results in a promotion, the promotee gets remembered, and it first
- scavenges objects adjacent to the promotee, then scavenges the ones reachable from the
- promoted. This loop continues until no more reachable objects are left. At that point,
- pastSurvivorSpace is exchanged with futureSurvivorSpace. Then any sdurviving weakArrays and
- weakArrays in the remembered set can be processed and their dead elements nilled.
-
- Answer the limit of pastSpace, to allow the memory manager to bounds check survivors."
-
- self scavengeLoop.
- self processWeaklings.
- self computeTenuringThreshold.
- self exchangeSurvivorSpaces.
- ^self initFutureSpaceStart!
Item was added:
+ ----- Method: SpurGenerationScavenger>>scavenge: (in category 'scavenger') -----
+ scavenge: tenuringCriterion
+ "The main routine, scavenge, scavenges young objects reachable from the roots (the stack zone
+ and the rememberedTable). It first scavenges the new objects immediately reachable from old
+ ones (all in the remembered table), then the stack zone. Then it scavenges those that are
+ transitively reachable. If this results in a promotion, the promotee gets remembered, and it first
+ scavenges objects adjacent to the promotee, then scavenges the ones reachable from the
+ promoted. This loop continues until no more reachable objects are left. At that point,
+ pastSurvivorSpace is exchanged with futureSurvivorSpace. Then any surviving weakArrays and
+ weakArrays in the remembered set can be processed and their dead elements nilled.
+
+ By default promotion (tenuring) is based on age and ammount of objects scavenged. But
+ tenuring can be based on e.g. a particular class. The argument selects the tenuring criterion.
+
+ Answer the limit of pastSpace, to allow the memory manager to bounds check survivors."
+ tenureCriterion := tenuringCriterion.
+ self scavengeLoop.
+ self processWeaklings.
+ self computeTenuringThreshold.
+ self exchangeSurvivorSpaces.
+ ^self initFutureSpaceStart!
Item was changed:
----- Method: SpurGenerationScavenger>>scavengeReferentsOf: (in category 'scavenger') -----
scavengeReferentsOf: referrer
+ "scavengeReferentsOf: referrer inspects all the pointers in referrer. If
+ any are new objects, it has them moved to FutureSurvivorSpace, and
+ answers truth. If there are no new referents, it answers falsity. To handle
+ weak arrays, if the referrer is weak only scavenge strong slots and answer
+ true so that it won't be removed from the remembered set until later."
- "scavengeReferentsOf: referrer inspects all the pointers in referrer.
- If any are new objects, it has them moved to FutureSurvivorSpace,
- and answers truth. If there are no new referents, it answers falsity.
- To handle weak arrays only scavenge string slots and answer true
- if the referrer is weak, so that it won't be removed from the
- remembered set until later."
| foundNewReferent |
"forwarding objects should be followed by callers,
unless the forwarder is a root in the remembered table."
self assert: ((manager isForwarded: referrer) not
or: [manager isRemembered: referrer]).
"unscanned ephemerons should be scanned later."
self assert: ((manager isEphemeron: referrer) not
or: [(self isScavengeSurvivor: (manager keyOfEphemeron: referrer))
or: [self is: referrer onWeaklingList: ephemeronList]]).
foundNewReferent := false.
0 to: (manager numStrongSlotsOf: referrer ephemeronInactiveIf: #isScavengeSurvivor:) - 1
do: [:i| | referent newLocation |
referent := manager fetchPointer: i ofMaybeForwardedObject: referrer.
(manager isNonImmediate: referent) ifTrue:
["a forwarding pointer could be because of become: or scavenging."
+ (manager isForwarded: referent) ifTrue:
+ [referent := manager followForwarded: referent].
+ ((manager isNonImmediate: referent)
+ and: [manager isYoung: referent])
- referent := (manager isForwarded: referent)
- ifTrue: [manager followForwarded: referent]
- ifFalse: [referent].
- (manager isYoung: referent)
ifTrue:
["if target is already in future space forwarding pointer was due to a become:."
(manager isInFutureSpace: referent)
ifTrue: [newLocation := referent]
ifFalse:
[(manager isForwarded: referent)
ifTrue: [self halt. "can this even happen?"
newLocation := manager followForwarded: referent]
ifFalse: [newLocation := self copyAndForward: referent]].
(manager isYoung: newLocation) ifTrue:
[foundNewReferent := true].
manager storePointerUnchecked: i ofMaybeForwardedObject: referrer withValue: newLocation]
ifFalse:
[manager storePointerUnchecked: i ofMaybeForwardedObject: referrer withValue: referent]]].
^foundNewReferent or: [manager isWeakNonImm: referrer]!
Item was changed:
----- Method: SpurGenerationScavenger>>scavengerTenuringThreshold (in category 'accessing') -----
scavengerTenuringThreshold "(Slang flattens so need unique selectors)"
<returnTypeC: #float>
+ ^tenureThreshold >= pastSpace start
+ ifTrue: [(tenureThreshold - pastSpace start) asFloat / (pastSpace limit - pastSpace start)]
- ^tenuringThreshold >= pastSpace start
- ifTrue: [(tenuringThreshold - pastSpace start) asFloat / (pastSpace limit - pastSpace start)]
ifFalse: [0]!
Item was changed:
----- Method: SpurGenerationScavenger>>scavengerTenuringThreshold: (in category 'accessing') -----
scavengerTenuringThreshold: aProportion "(Slang flattens so need unique selectors)"
<var: 'aProportion' type: #float>
tenuringProportion := aProportion.
+ tenureThreshold := aProportion = 0.0
- tenuringThreshold := aProportion = 0.0
ifTrue: [0]
ifFalse: [((pastSpace limit - pastSpace start) * (1.0 - aProportion)) rounded + pastSpace start]!
Item was changed:
----- Method: SpurGenerationScavenger>>setRawTenuringThreshold: (in category 'accessing') -----
setRawTenuringThreshold: threshold
+ tenureThreshold := threshold!
- tenuringThreshold := threshold!
Item was changed:
----- Method: SpurGenerationScavenger>>shouldBeTenured: (in category 'scavenger') -----
shouldBeTenured: survivor
"Answer if an object should be tenured. Use the tenuringThreshold to decide.
If the survivors (measured in bytes) are above some fraction of the survivor
space then objects below the threshold (older objects, since allocation grows
upwards and hence new objects are later than old) are scavenged. Otherwise,
the threshold is set to 0 and no objects are tenured. See e.g.
An adaptive tenuring policy for generation scavengers, David Ungar & Frank Jackson.
ACM TOPLAS, Volume 14 Issue 1, Jan. 1992, pp 1 - 27."
+ ^tenureCriterion
+ caseOf: {
+ [TenureByAge] ->
+ [survivor < tenureThreshold].
+ [TenureByClass] ->
+ [(manager classIndexOf: survivor) = tenuringClassIndex] }
+ otherwise: [false]!
- ^tenuringCriterion caseOf: {
- [TenureByAge] ->
- [survivor < tenuringThreshold
- and: [survivor >= manager startOfMemory]]. "exclude methods in the method zone"
- [TenureByClass] ->
- [(manager classIndexOf: survivor) = tenuringClassIndex
- and: [survivor >= manager startOfMemory]] "exclude methods in the method zone"}!
Item was removed:
- ----- Method: SpurGenerationScavenger>>tenuringCriterion (in category 'accessing') -----
- tenuringCriterion
- ^tenuringCriterion!
Item was removed:
- ----- Method: SpurGenerationScavenger>>tenuringCriterion: (in category 'accessing') -----
- tenuringCriterion: anInteger
- tenuringCriterion := anInteger!
Item was changed:
SpurGenerationScavenger subclass: #SpurGenerationScavengerSimulator
+ instanceVariableNames: ''
- instanceVariableNames: 'comeFroms'
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-SpurMemoryManagerSimulation'!
Item was removed:
- ----- Method: SpurGenerationScavengerSimulator>>copyAndForward: (in category 'scavenger') -----
- copyAndForward: survivor
- | newLocation |
- "(#(16r167280 16r19A670) includes: survivor) ifTrue: [self halt]."
- true ifTrue: [^super copyAndForward: survivor.].
- newLocation := super copyAndForward: survivor.
- comeFroms at: newLocation put: survivor.
- "((manager isContextNonImm: newLocation)
- and: [#(16r11D6988 16r11D6A48 16r11D6AC0 16r11D6B80) includes: newLocation]) ifTrue:
- [self halt]."
- ^newLocation!
Item was removed:
- ----- Method: SpurGenerationScavengerSimulator>>scavenge (in category 'scavenger') -----
- scavenge
- comeFroms := Dictionary new.
- ^super scavenge!
Item was changed:
CogClass subclass: #SpurMemoryManager
(excessive size, no diff calculated)
Item was added:
+ ----- Method: SpurMemoryManager class>>ancilliaryClasses: (in category 'translation') -----
+ ancilliaryClasses: options
+ ^{ SpurGenerationScavenger. SpurNewSpaceSpace.
+ SpurSegmentManager. SpurSegmentInfo }!
Item was added:
+ ----- Method: SpurMemoryManager class>>declareCVarsIn: (in category 'translation') -----
+ declareCVarsIn: aCCodeGenerator
+ self declareCAsOop: #(memory freeStart scavengeThreshold newSpaceLimit lowSpaceThreshold freeOldSpaceStart endOfMemory sortedFreeChunks)
+ in: aCCodeGenerator.
+ self declareCAsUSqLong: (self allInstVarNames select: [:ivn| ivn endsWith: 'Usecs'])
+ in: aCCodeGenerator.
+ aCCodeGenerator var: #freeLists declareC: #'sqInt *freeLists'.
+ aCCodeGenerator
+ var: #remapBuffer
+ declareC: 'sqInt remapBuffer[RemapBufferSize + 1 /* ', (RemapBufferSize + 1) printString, ' */]'!
Item was changed:
----- Method: SpurMemoryManager class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') -----
isNonArgumentImplicitReceiverVariableName: aString
+ ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager' 'heapMap') includes: aString!
- ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager') includes: aString!
Item was changed:
----- Method: SpurMemoryManager>>addressCouldBeObj: (in category 'debug support') -----
addressCouldBeObj: address
<api>
- self flag: #temporary. "include futureSpace for now (while debugging the scavenger)"
^(address bitAnd: self baseHeaderSize - 1) = 0
and: [(self isInOldSpace: address)
+ or: [(self isInEden: address)
- or: (self isInEden: address)
or: [(self isInSurvivorSpace: address)
+ "or: [scavengeInProgress and: [self isInFutureSpace: address]"]]]!
- or: [scavengeInProgress and: [self isInFutureSpace: address]]]]!
Item was changed:
----- Method: SpurMemoryManager>>allExistingNewSpaceObjectsDo: (in category 'object enumeration') -----
allExistingNewSpaceObjectsDo: aBlock
<inline: true>
| prevObj prevPrevObj objOop limit |
prevPrevObj := prevObj := nil.
"After a scavenge eden is empty, futureSpace is empty, and all newSpace objects are
in pastSpace. Objects are allocated in eden. So enumerate only eden and pastSpace."
objOop := self objectStartingAt: scavenger eden start.
limit := freeStart.
[objOop < limit] whileTrue:
[(self isFreeObject: objOop) ifFalse:
[aBlock value: objOop].
prevPrevObj := prevObj.
prevObj := objOop.
objOop := self objectAfter: objOop limit: freeStart].
objOop := self objectStartingAt: scavenger pastSpace start.
limit := pastSpaceStart.
[objOop < limit] whileTrue:
[(self isFreeObject: objOop) ifFalse:
[aBlock value: objOop].
prevPrevObj := prevObj.
prevObj := objOop.
objOop := self objectAfter: objOop limit: limit].
+ self touch: prevPrevObj.
+ self touch: prevObj!
- prevPrevObj class.
- prevObj class!
Item was changed:
----- Method: SpurMemoryManager>>allExistingOldSpaceObjectsDo: (in category 'object enumeration') -----
allExistingOldSpaceObjectsDo: aBlock
"Enumerate all old space objects, excluding any objects created
during the execution of allExistingOldSpaceObjectsDo:."
<inline: true>
| oldSpaceLimit prevObj prevPrevObj objOop |
prevPrevObj := prevObj := nil.
objOop := self firstObject.
oldSpaceLimit := freeOldSpaceStart.
[self assert: objOop \\ self allocationUnit = 0.
objOop < oldSpaceLimit] whileTrue:
[(self isFreeObject: objOop) ifFalse:
[aBlock value: objOop].
prevPrevObj := prevObj.
prevObj := objOop.
objOop := self objectAfter: objOop limit: freeOldSpaceStart].
+ self touch: prevPrevObj.
+ self touch: prevObj!
- prevPrevObj class.
- prevObj class!
Item was changed:
----- Method: SpurMemoryManager>>allNewSpaceEntitiesDo: (in category 'object enumeration') -----
allNewSpaceEntitiesDo: aBlock
"Enumerate all new space objects, including free objects,
excluding any objects created during the ennumeration."
<inline: true>
| prevObj prevPrevObj objOop limit |
prevPrevObj := prevObj := nil.
"After a scavenge eden is empty, futureSpace is empty, and all newSpace objects are
in pastSpace. Objects are allocated in eden. So enumerate only eden and pastSpace."
objOop := self objectStartingAt: scavenger eden start.
[objOop < freeStart] whileTrue:
[aBlock value: objOop.
prevPrevObj := prevObj.
prevObj := objOop.
objOop := self objectAfter: objOop limit: freeStart].
objOop := self objectStartingAt: scavenger pastSpace start.
limit := pastSpaceStart.
[objOop < limit] whileTrue:
[aBlock value: objOop.
prevPrevObj := prevObj.
prevObj := objOop.
objOop := self objectAfter: objOop limit: limit].
+ self touch: prevPrevObj.
+ self touch: prevObj!
- prevPrevObj class.
- prevObj class!
Item was changed:
----- Method: SpurMemoryManager>>allNewSpaceObjectsDo: (in category 'object enumeration') -----
allNewSpaceObjectsDo: aBlock
"Enumerate all new space objects, excluding any objects created
during the execution of allNewSpaceObjectsDo:."
<inline: true>
| prevObj prevPrevObj objOop limit |
prevPrevObj := prevObj := nil.
"After a scavenge eden is empty, futureSpace is empty, and all newSpace objects are
in pastSpace. Objects are allocated in eden. So enumerate only eden and pastSpace."
objOop := self objectStartingAt: scavenger eden start.
[objOop < freeStart] whileTrue:
[(self isFreeObject: objOop) ifFalse:
[aBlock value: objOop].
prevPrevObj := prevObj.
prevObj := objOop.
objOop := self objectAfter: objOop limit: freeStart].
objOop := self objectStartingAt: scavenger pastSpace start.
limit := pastSpaceStart.
[objOop < limit] whileTrue:
[(self isFreeObject: objOop) ifFalse:
[aBlock value: objOop].
prevPrevObj := prevObj.
prevObj := objOop.
objOop := self objectAfter: objOop limit: limit].
+ self touch: prevPrevObj.
+ self touch: prevObj!
- prevPrevObj class.
- prevObj class!
Item was changed:
----- Method: SpurMemoryManager>>allOldSpaceEntitiesDo: (in category 'object enumeration') -----
allOldSpaceEntitiesDo: aBlock
<inline: true>
| prevObj prevPrevObj objOop |
prevPrevObj := prevObj := nil.
objOop := self firstObject.
[self assert: objOop \\ self allocationUnit = 0.
objOop < freeOldSpaceStart] whileTrue:
[aBlock value: objOop.
prevPrevObj := prevObj.
prevObj := objOop.
objOop := self objectAfter: objOop limit: freeOldSpaceStart].
+ self touch: prevPrevObj.
+ self touch: prevObj!
- prevPrevObj class.
- prevObj class!
Item was changed:
----- Method: SpurMemoryManager>>allOldSpaceObjectsFrom:do: (in category 'object enumeration') -----
allOldSpaceObjectsFrom: initialObject do: aBlock
<inline: true>
| prevObj prevPrevObj objOop |
prevPrevObj := prevObj := nil.
objOop := initialObject.
[self assert: objOop \\ self allocationUnit = 0.
objOop < freeOldSpaceStart] whileTrue:
[(self isFreeObject: objOop) ifFalse:
[aBlock value: objOop].
prevPrevObj := prevObj.
prevObj := objOop.
objOop := self objectAfter: objOop limit: freeOldSpaceStart].
+ self touch: prevPrevObj.
+ self touch: prevObj!
- prevPrevObj class.
- prevObj class!
Item was changed:
----- Method: SpurMemoryManager>>bytesInFreeTree: (in category 'free space') -----
bytesInFreeTree: freeNode
+ | freeBytes bytesInObj listNode |
- | freeBytes bytesInObject listNode |
freeNode = 0 ifTrue: [^0].
freeBytes := 0.
+ bytesInObj := self bytesInObject: freeNode.
+ self assert: bytesInObj / self allocationUnit >= self numFreeLists.
- bytesInObject := self bytesInObject: freeNode.
- self assert: bytesInObject / self allocationUnit >= self numFreeLists.
listNode := freeNode.
[listNode ~= 0] whileTrue:
["self printFreeChunk: listNode"
self assert: (self isValidFreeObject: listNode).
+ freeBytes := freeBytes + bytesInObj.
+ self assert: bytesInObj = (self bytesInObject: listNode).
- freeBytes := freeBytes + bytesInObject.
- self assert: bytesInObject = (self bytesInObject: listNode).
listNode := self fetchPointer: self freeChunkNextIndex ofFreeChunk: listNode].
^freeBytes
+ (self bytesInFreeTree: (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: freeNode))
+ (self bytesInFreeTree: (self fetchPointer: self freeChunkLargerIndex ofFreeChunk: freeNode))!
Item was added:
+ ----- Method: SpurMemoryManager>>forwardSurvivor:to: (in category 'become implementation') -----
+ forwardSurvivor: obj1 to: obj2
+ self assert: (self isInNewSpace: obj1).
+ self storePointerUnchecked: 0 ofObject: obj1 withValue: obj2.
+ self setFormatOf: obj1 to: self forwardedFormat.
+ self setClassIndexOf: obj1 to: self isForwardedObjectClassIndexPun!
Item was changed:
----- Method: SpurMemoryManager>>freeChunkWithBytes:at: (in category 'free space') -----
freeChunkWithBytes: bytes at: address
+ <inline: false>
- <inline: true>
| freeChunk |
freeChunk := self initFreeChunkWithBytes: bytes at: address.
self addToFreeList: freeChunk bytes: bytes.
^freeChunk!
Item was changed:
----- Method: SpurMemoryManager>>freeStart (in category 'accessing') -----
freeStart
+ "This is a horrible hack and only works because C macros are generated after Interpreter variables."
+ <cmacro: '() GIV(freeStart)'>
^freeStart!
Item was changed:
----- Method: SpurMemoryManager>>initSpaceForAllocationCheck: (in category 'allocation') -----
initSpaceForAllocationCheck: aNewSpace
+ <var: 'aNewSpace' type: #'SpurNewSpaceSpace *'>
memory ifNotNil:
[CheckObjectOverwrite ifTrue:
[aNewSpace start
to: aNewSpace limit - 1
by: self wordSize
do: [:p| self longAt: p put: p]]]!
Item was changed:
----- Method: SpurMemoryManager>>initialize (in category 'initialization') -----
initialize
"We can put all initializations that set something to 0 or to false here.
In C all global variables are initialized to 0, and 0 is false."
remapBuffer := Array new: RemapBufferSize.
remapBufferCount := 0.
freeListsMask := totalFreeOldSpace := lowSpaceThreshold := 0.
checkForLeaks := 0.
needGCFlag := signalLowSpace := scavengeInProgress := false.
becomeEffectsFlags := 0.
statScavenges := statIncrGCs := statFullGCs := 0.
statScavengeGCUsecs := statIncrGCUsecs := statFullGCUsecs := 0.
statSGCDeltaUsecs := statIGCDeltaUsecs := statFGCDeltaUsecs := 0.
+ self flag: #temporary.
+ shrinkThreshold := 16r10000000. "something huge for now"
"we can initialize things that are virtual in C."
scavenger := SpurGenerationScavengerSimulator new manager: self; yourself.
segmentManager := SpurSegmentManager new manager: self; yourself.
"We can also initialize here anything that is only for simulation."
heapMap := self wordSize = 4 ifTrue: [CogCheck32BitHeapMap new]!
Item was changed:
----- Method: SpurMemoryManager>>initializeNewSpaceVariables (in category 'generation scavenging') -----
initializeNewSpaceVariables
startOfMemory ifNotNil: "true in bootstrap"
[^self].
freeStart := scavenger eden start.
pastSpaceStart := scavenger pastSpace start.
scavengeThreshold := scavenger eden limit
- (scavenger edenBytes / 64)
- coInterpreter interpreterAllocationReserveBytes.
startOfMemory := scavenger pastSpace start min: scavenger futureSpace start.
self assert: startOfMemory < scavenger eden start.
+ self initSpaceForAllocationCheck: (self addressOf: scavenger eden)!
- self initSpaceForAllocationCheck: scavenger eden!
Item was added:
+ ----- Method: SpurMemoryManager>>isInNewSpace: (in category 'object testing') -----
+ isInNewSpace: objOop
+ ^objOop >= startOfMemory
+ and: [objOop < newSpaceLimit]!
Item was changed:
----- Method: SpurMemoryManager>>newSpaceLimit (in category 'accessing') -----
newSpaceLimit
+ <cmacro: '() GIV(newSpaceLimit)'>
^newSpaceLimit!
Item was added:
+ ----- Method: SpurMemoryManager>>newSpaceSize (in category 'accessing') -----
+ newSpaceSize
+ ^(freeStart - scavenger eden start)
+ + (pastSpaceStart - scavenger pastSpace start)!
Item was changed:
----- Method: SpurMemoryManager>>objectAfter: (in category 'object enumeration') -----
objectAfter: objOop
"Object parsing.
1. all objects have at least a word following the header, for a forwarding pointer.
2. objects with an overflow size have a preceeing word with a saturated slotSize. If the word following
an object doesn't have a saturated size field it must be a single-header object. If the word following
does have a saturated slotSize it must be the overflow size word."
+ <inline: false>
objOop < newSpaceLimit ifTrue:
[(self isInEden: objOop) ifTrue:
[^self objectAfter: objOop limit: freeStart].
(self isInSurvivorSpace: objOop) ifTrue:
[^self objectAfter: objOop limit: pastSpaceStart].
^self objectAfter: objOop limit: scavenger futureSurvivorStart].
^self objectAfter: objOop limit: freeOldSpaceStart!
Item was changed:
----- Method: SpurMemoryManager>>printReferencesTo: (in category 'debug printing') -----
printReferencesTo: anOop
"Scan the heap printing the oops of any and all objects that refer to anOop"
<api>
self allObjectsDo:
[:obj| | i |
+ i := self numPointerSlotsOf: obj.
+ [(i := i - 1) >= 0] whileTrue:
+ [anOop = (self fetchPointer: i ofObject: obj) ifTrue:
+ [coInterpreter printHex: obj; print: ' @ '; printNum: i; space; printOopShort: obj; cr.
+ i := 0]]]!
- ((self isPointersNonImm: obj) or: [self isCompiledMethod: obj])
- ifTrue:
- [(self isCompiledMethod: obj)
- ifTrue:
- [i := (coInterpreter literalCountOf: obj) + LiteralStart]
- ifFalse:
- [(self isContextNonImm: obj)
- ifTrue: [i := CtxtTempFrameStart + (coInterpreter fetchStackPointerOf: obj)]
- ifFalse: [i := self lengthOf: obj]].
- [(i := i - 1) >= 0] whileTrue:
- [anOop = (self fetchPointer: i ofObject: obj) ifTrue:
- [coInterpreter printHex: obj; print: ' @ '; printNum: i; space; printOopShort: obj; cr.
- i := 0]]]
- ifFalse:
- [((self isForwarded: obj)
- and: [(self fetchPointer: 0 ofMaybeForwardedObject: obj) = anOop]) ifTrue:
- [coInterpreter printHex: obj; print: ' => '; printHex: anOop; cr]]]!
Item was added:
+ ----- Method: SpurMemoryManager>>remapBufferCount (in category 'accessing') -----
+ remapBufferCount
+ ^remapBufferCount!
Item was changed:
----- Method: SpurMemoryManager>>remapObj: (in category 'generation scavenging') -----
remapObj: objOop
"Scavenge or simply follow objOop. Answer the new location of objOop. The
send should have been guarded by a send of shouldRemapOop: or shouldScavengeObj:.
The method is called remapObj: for compatibility with ObjectMemory."
<inline: false>
| resolvedObj |
+ self assert: (self shouldRemapOop: objOop).
(self isForwarded: objOop)
ifTrue:
[resolvedObj := self followForwarded: objOop.
(self isYoung: resolvedObj) ifFalse: "a becommed object whose target is in old space"
[^resolvedObj].
(self isInFutureSpace: resolvedObj) ifTrue: "already scavenged"
[^resolvedObj]]
ifFalse:
[resolvedObj := objOop].
^scavenger copyAndForward: resolvedObj!
Item was changed:
----- Method: SpurMemoryManager>>scavengingGCTenuringIf: (in category 'generation scavenging') -----
scavengingGCTenuringIf: tenuringCriterion
"Run the scavenger."
self assert: remapBufferCount = 0.
self assert: (segmentManager numSegments = 0 "true in the spur image bootstrap"
or: [scavenger eden limit - freeStart > coInterpreter interpreterAllocationReserveBytes]).
self checkFreeSpace.
"coInterpreter printCallStackFP: coInterpreter framePointer"
self runLeakCheckerForFullGC: false.
coInterpreter
preGCAction: GCModeIncr;
"would prefer this to be in mapInterpreterOops, but
compatibility with ObjectMemory dictates it goes here."
flushMethodCacheFrom: startOfMemory to: newSpaceLimit.
needGCFlag := false.
gcStartUsecs := coInterpreter ioUTCMicrosecondsNow.
scavengeInProgress := true.
+ pastSpaceStart := scavenger scavenge: tenuringCriterion.
- scavenger tenuringCriterion: tenuringCriterion.
- pastSpaceStart := scavenger scavenge.
self assert: (self
oop: pastSpaceStart
isGreaterThanOrEqualTo: scavenger pastSpace start
andLessThanOrEqualTo: scavenger pastSpace limit).
freeStart := scavenger eden start.
+ self initSpaceForAllocationCheck: (self addressOf: scavenger eden).
- self initSpaceForAllocationCheck: scavenger eden.
scavengeInProgress := false.
statScavenges := statScavenges + 1.
statGCEndUsecs := coInterpreter ioUTCMicrosecondsNow.
statSGCDeltaUsecs := statGCEndUsecs - gcStartUsecs.
statScavengeGCUsecs := statScavengeGCUsecs + statSGCDeltaUsecs.
coInterpreter postGCAction.
self runLeakCheckerForFullGC: false.
self checkFreeSpace!
Item was changed:
----- Method: SpurMemoryManager>>shrinkThreshold (in category 'free space') -----
shrinkThreshold
+ ^shrinkThreshold!
- self flag: #temporary.
- ^SmallInteger maxVal!
Item was added:
+ ----- Method: SpurMemoryManager>>shrinkThreshold: (in category 'free space') -----
+ shrinkThreshold: aValue
+ shrinkThreshold := aValue!
Item was added:
+ ----- Method: SpurMemoryManager>>signalLowSpace: (in category 'accessing') -----
+ signalLowSpace: aValue
+ ^signalLowSpace := aValue!
Item was changed:
----- Method: SpurMemoryManager>>startOfMemory (in category 'accessing') -----
startOfMemory
+ "Return the start of object memory. This is immediately after the native code zone."
- "Return the start of object memory. This is immediately after the native code zone.
- N.B. the stack zone is alloca'ed. Use a macro so as not to punish the debug VM."
- <cmacro: '() heapBase'> "This is for CoInterpreter, not StackInterpreter"
<returnTypeC: #usqInt>
+ <cmacro: '() GIV(startOfMemory)'>
- self flag: #fixme.
^startOfMemory ifNil: [0]!
Item was added:
+ ----- Method: SpurMemoryManager>>statFullGCUsecs (in category 'accessing') -----
+ statFullGCUsecs
+ ^statFullGCUsecs!
Item was added:
+ ----- Method: SpurMemoryManager>>statFullGCs (in category 'accessing') -----
+ statFullGCs
+ ^statFullGCs!
Item was added:
+ ----- Method: SpurMemoryManager>>statIGCDeltaUsecs (in category 'accessing') -----
+ statIGCDeltaUsecs
+ ^statIGCDeltaUsecs!
Item was added:
+ ----- Method: SpurMemoryManager>>statIncrGCUsecs (in category 'accessing') -----
+ statIncrGCUsecs
+ ^statIncrGCUsecs!
Item was added:
+ ----- Method: SpurMemoryManager>>statIncrGCs (in category 'accessing') -----
+ statIncrGCs
+ ^statIncrGCs!
Item was changed:
----- Method: SpurMemoryManager>>totalFreeListBytes (in category 'free space') -----
totalFreeListBytes
+ | freeBytes bytesInObj obj |
- | freeBytes bytesInObject obj |
freeBytes := 0.
1 to: self numFreeLists - 1 do:
[:i|
+ bytesInObj := i * self allocationUnit.
- bytesInObject := i * self allocationUnit.
obj := freeLists at: i.
[obj ~= 0] whileTrue:
+ [freeBytes := freeBytes + bytesInObj.
- [freeBytes := freeBytes + bytesInObject.
self assert: (self isValidFreeObject: obj).
+ self assert: bytesInObj = (self bytesInObject: obj).
- self assert: bytesInObject = (self bytesInObject: obj).
obj := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj]].
^freeBytes + (self bytesInFreeTree: (freeLists at: 0))!
Item was added:
+ ----- Method: SpurMemoryManager>>totalMemorySize (in category 'accessing') -----
+ totalMemorySize
+ ^scavenger newSpaceCapacity + segmentManager totalSegmentSize!
Item was changed:
----- Method: SpurMemoryManager>>vmEndianness (in category 'memory access') -----
vmEndianness
+ <cmacro: '() VMBIGENDIAN'>
"1 = big, 0 = little"
^self subclassResponsibility!
Item was added:
+ ----- Method: SpurNewSpaceSpace class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') -----
+ instVarNamesAndTypesForTranslationDo: aBinaryBlock
+ self instVarNames do:
+ [:ivn| aBinaryBlock value: ivn value: #usqInt]!
Item was changed:
----- Method: SpurNewSpaceSpace>>printOn: (in category 'printing') -----
+ printOn: aStream
+ <doNotGenerate>
- printOn: aStream.
super printOn: aStream.
(start notNil and: [limit notNil]) ifTrue:
[aStream nextPutAll: ' start: '; nextPutAll: start hex; nextPutAll: ' limit: '; nextPutAll: limit hex]!
Item was removed:
- ----- Method: SpurNewSpaceSpace>>start:limit: (in category 'initialization') -----
- start: startAddress limit: limitAddress
- start := startAddress.
- limit := limitAddress!
Item was changed:
VMStructType subclass: #SpurSegmentInfo
+ instanceVariableNames: 'segStart segSize swizzle'
- instanceVariableNames: 'start segSize swizzle'
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-SpurMemoryManager'!
Item was changed:
----- Method: SpurSegmentInfo>>printOn: (in category 'printing') -----
printOn: aStream
+ <doNotGenerate>
super printOn: aStream.
self class instVarNames do:
[:name| | iv |
iv := self instVarNamed: name.
aStream space; nextPutAll: name; space; print: iv.
iv isInteger ifTrue:
[aStream nextPut: $/. iv storeOn: aStream base: 16]]!
Item was added:
+ ----- Method: SpurSegmentInfo>>segStart (in category 'accessing') -----
+ segStart
+ "Answer the value of segStart"
+
+ ^ segStart!
Item was added:
+ ----- Method: SpurSegmentInfo>>segStart: (in category 'accessing') -----
+ segStart: anObject
+ "Set the value of segStart"
+
+ ^segStart := anObject!
Item was removed:
- ----- Method: SpurSegmentInfo>>start (in category 'accessing') -----
- start
- "Answer the value of start"
-
- ^ start!
Item was removed:
- ----- Method: SpurSegmentInfo>>start: (in category 'accessing') -----
- start: anObject
- "Set the value of start"
-
- ^start := anObject!
Item was added:
+ ----- Method: SpurSegmentManager class>>declareCVarsIn: (in category 'translation') -----
+ declareCVarsIn: aCCodeGenerator
+ aCCodeGenerator var: #segments type: #'SpurSegmentInfo *'!
Item was added:
+ ----- Method: SpurSegmentManager class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') -----
+ isNonArgumentImplicitReceiverVariableName: instVarName
+ ^instVarName = 'manager'!
Item was changed:
----- Method: SpurSegmentManager>>adjustSegmentSwizzlesBy: (in category 'snapshot') -----
adjustSegmentSwizzlesBy: firstSegmentShift
"Adjust swizzles by firstSegmentShift."
<var: 'segInfo' type: 'SpurSegmentInfo *'>
| oldBaseAddr |
oldBaseAddr := manager memoryBaseForImageRead - firstSegmentShift.
0 to: numSegments - 1 do:
[:i| | segInfo |
segInfo := self addressOf: (segments at: i).
segInfo
+ segStart: segInfo segStart + oldBaseAddr;
- start: segInfo start + oldBaseAddr;
swizzle: segInfo swizzle - oldBaseAddr].
canSwizzle := true!
Item was changed:
----- Method: SpurSegmentManager>>collapseSegmentsPostSwizzle (in category 'snapshot') -----
collapseSegmentsPostSwizzle
"The image has been loaded, old segments reconstructed, and the
loaded image swizzled into a single contiguous segment. Collapse
the segments intio one."
| bridge |
canSwizzle := false.
firstSegmentSize ifNil: "true when used by SpurBootstrap to transform an image"
[^self].
numSegments := 1.
+ (self addressOf: (segments at: 0))
+ segStart: manager newSpaceLimit;
- (segments at: 0)
- start: manager newSpaceLimit;
segSize: manager endOfMemory.
"finally plant a bridge at the end of the coallesced segment and cut back the
manager's ntion of the end of memory to immediately before the bridge."
bridge := manager endOfMemory - manager bridgeSize.
manager
initSegmentBridgeWithBytes: manager bridgeSize at: bridge;
setEndOfMemory: bridge!
Item was changed:
----- Method: SpurSegmentManager>>numSegments (in category 'accessing') -----
numSegments
+ <cmacro: '() GIV(numSegments)'>
^numSegments!
Item was changed:
----- Method: SpurSegmentManager>>readHeapFromImageFile:dataBytes: (in category 'snapshot') -----
readHeapFromImageFile: f dataBytes: numBytes
"Read numBytes of image data from f into memory at memoryBaseForImageRead.
Answer the number of bytes written. In addition, read each segment, build up the
segment info, while eliminating the bridge objects that end each segment and
give the size of the subsequent segment."
| bytesRead totalBytesRead bridge nextSegmentSize oldBase newBase segInfo bridgeSpan |
<var: 'segInfo' type: 'SpurSegmentInfo *'>
self allocateOrExtendSegmentInfos.
"segment sizes include the two-header-word bridge at the end of each segment."
numSegments := totalBytesRead := 0.
oldBase := 0. "N.B. still must be adjusted by oldBaseAddr."
newBase := manager newSpaceLimit.
nextSegmentSize := firstSegmentSize.
bridge := firstSegmentSize + manager newSpaceLimit - manager baseHeaderSize.
[segInfo := self addressOf: (segments at: numSegments).
segInfo
+ segStart: oldBase; "N.B. still must be adjusted by oldBaseAddr."
- start: oldBase; "N.B. still must be adjusted by oldBaseAddr."
segSize: nextSegmentSize;
swizzle: newBase - oldBase. "N.B. still must be adjusted by oldBaseAddr."
bytesRead := self readHeapFrom: f at: newBase dataBytes: nextSegmentSize.
bytesRead > 0 ifTrue:
[totalBytesRead := totalBytesRead + bytesRead].
bytesRead ~= nextSegmentSize ifTrue:
[^totalBytesRead].
numSegments := numSegments + 1.
bridgeSpan := manager bytesPerSlot * (manager rawOverflowSlotsOf: bridge).
oldBase := oldBase + nextSegmentSize + bridgeSpan.
newBase := newBase + nextSegmentSize - manager bridgeSize.
nextSegmentSize := manager longLongAt: bridge.
nextSegmentSize ~= 0] whileTrue:
[bridge := bridge - manager bridgeSize + nextSegmentSize].
"newBase should point just past the last bridge. all others should have been eliminated."
self assert: newBase - manager newSpaceLimit
= (totalBytesRead - (numSegments * manager bridgeSize)).
"set freeOldSpaceStart now for adjustAllOopsBy:"
manager setFreeOldSpaceStart: newBase.
^totalBytesRead!
Item was changed:
----- Method: SpurSegmentManager>>swizzleObj: (in category 'snapshot') -----
swizzleObj: objOop
+ <inline: false>
self assert: canSwizzle.
numSegments - 1 to: 1 by: -1 do:
[:i|
+ objOop >= (segments at: i) segStart ifTrue:
- objOop >= (segments at: i) start ifTrue:
[^objOop + (segments at: i) swizzle]].
^objOop + (segments at: 0) swizzle!
Item was changed:
----- Method: SpurSegmentManager>>writeImageToFile: (in category 'snapshot') -----
writeImageToFile: aBinaryStream
| total |
total := 0.
firstSegmentSize ifNotNil:
[self assert: firstSegmentSize = (segments at: 0) segSize].
0 to: numSegments - 1 do:
[:i| | nextSegSize |
nextSegSize := i = (numSegments - 1)
ifTrue: [0]
ifFalse: [(segments at: i + 1) segSize].
+ total := total + (self writeSegment: (self addressOf: (segments at: i))
- total := total + (self writeSegment: (segments at: i)
nextSegmentSize: nextSegSize
toFile: aBinaryStream)].
^total!
Item was changed:
----- Method: SpurSegmentManager>>writeSegment:nextSegmentSize:toFile: (in category 'snapshot') -----
writeSegment: aSpurSegmentInfo nextSegmentSize: nextSegSize toFile: aBinaryStream
+ <var: 'aSpurSegmentInfo' type: #'SpurSegmentInfo *'>
- <var: 'aSpurSegmentInfo' type: 'SpurSegmentInfo *'>
<var: 'aBinaryStream' type: #'FILE *'>
| bridge savedHeader nWritten |
<var: 'savedHeader' type: #usqLong>
+ bridge := aSpurSegmentInfo segStart + aSpurSegmentInfo segSize - manager baseHeaderSize.
- bridge := aSpurSegmentInfo start + aSpurSegmentInfo segSize - manager baseHeaderSize.
"last seg may be beyond endOfMemory/freeOldSpaceStart"
self assert: ((manager isValidSegmentBridge: bridge) or: [nextSegSize = 0]).
savedHeader := manager longLongAt: bridge.
manager longLongAt: bridge put: nextSegSize.
nWritten := self cCode:
[self
+ sq: aSpurSegmentInfo segStart
- sq: aSpurSegmentInfo start
Image: 1
File: aSpurSegmentInfo segSize
Write: aBinaryStream]
inSmalltalk:
[aBinaryStream
next: aSpurSegmentInfo segSize / 4
putAll: manager memory
+ startingAt: aSpurSegmentInfo segStart / 4 + 1.
- startingAt: aSpurSegmentInfo start / 4 + 1.
aSpurSegmentInfo segSize].
manager longLongAt: bridge put: savedHeader.
^nWritten!
Item was changed:
----- Method: StackInterpreter class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses"
aCCodeGenerator
addHeaderFile:'<stddef.h> /* for e.g. alloca */';
addHeaderFile:'<setjmp.h>';
addHeaderFile:'"vmCallback.h"';
addHeaderFile:'"sqMemoryFence.h"';
addHeaderFile:'"dispdbg.h"'.
self declareInterpreterVersionIn: aCCodeGenerator
defaultName: 'Stack'.
aCCodeGenerator
var: #interpreterProxy type: #'struct VirtualMachine*'.
aCCodeGenerator
declareVar: #sendTrace type: 'volatile int';
declareVar: #byteCount type: 'unsigned long'.
"These need to be pointers or unsigned."
self declareC: #(instructionPointer method newMethod)
as: #usqInt
in: aCCodeGenerator.
"These are all pointers; char * because Slang has no support for C pointer arithmetic."
self declareC: #(localIP localSP localFP stackPointer framePointer stackLimit stackMemory)
as: #'char *'
in: aCCodeGenerator.
self declareC: #(stackPage overflowedPage)
as: #'StackPage *'
in: aCCodeGenerator.
aCCodeGenerator removeVariable: 'stackPages'. "this is an implicit receiver in the translated code."
"This defines bytecodeSetSelector as 0 if MULTIPLEBYTECODESETS
is not defined, for the benefit of the interpreter on slow machines."
aCCodeGenerator addConstantForBinding: (self bindingOf: #MULTIPLEBYTECODESETS).
MULTIPLEBYTECODESETS == false ifTrue:
[aCCodeGenerator
removeVariable: 'extA';
removeVariable: 'extB';
removeVariable: 'bytecodeSetSelector'].
aCCodeGenerator
var: #methodCache
declareC: 'long methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'.
aCCodeGenerator
var: #atCache
declareC: 'sqInt atCache[AtCacheTotalSize + 1 /* ', (AtCacheTotalSize + 1) printString, ' */]'.
aCCodeGenerator
var: #primitiveTable
declareC: 'void (*primitiveTable[MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex +2) printString, ' */])(void) = ', self primitiveTableString.
self primitiveTable do:
[:symbolOrNot|
(symbolOrNot isSymbol
and: [symbolOrNot ~~ #primitiveFail]) ifTrue:
[(aCCodeGenerator methodNamed: symbolOrNot) ifNotNil:
[:tMethod| tMethod returnType: #void]]].
aCCodeGenerator
var: #primitiveFunctionPointer
declareC: 'void (*primitiveFunctionPointer)()'.
aCCodeGenerator
var: #externalPrimitiveTable
declareC: 'void (*externalPrimitiveTable[MaxExternalPrimitiveTableSize + 1 /* ', (MaxExternalPrimitiveTableSize + 1) printString, ' */])(void)'.
aCCodeGenerator var: #showSurfaceFn type: #'void *'.
aCCodeGenerator
var: #jmpBuf
declareC: 'jmp_buf jmpBuf[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #suspendedCallbacks
declareC: 'usqInt suspendedCallbacks[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #suspendedMethods
declareC: 'usqInt suspendedMethods[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #interruptCheckChain
declareC: 'void (*interruptCheckChain)(void) = 0'.
aCCodeGenerator
var: #breakSelector type: #'char *';
var: #breakSelectorLength
declareC: 'sqInt breakSelectorLength = -1'.
+ self declareCAsUSqLong: #(nextPollUsecs nextWakeupUsecs longRunningPrimitiveGCUsecs
+ longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs)
- self declareC: #(nextPollUsecs nextWakeupUsecs longRunningPrimitiveGCUsecs
- longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs)
- as: #usqLong
in: aCCodeGenerator.
aCCodeGenerator var: #nextProfileTick type: #sqLong!
Item was changed:
----- Method: StackInterpreter class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') -----
isNonArgumentImplicitReceiverVariableName: aString
+ ^(#('self' 'stackPages' 'interpreter' 'coInterpreter' 'objectMemory') includes: aString)
+ or: [self objectMemoryClass isNonArgumentImplicitReceiverVariableName: aString]!
- ^#('self' 'stackPages' 'interpreter' 'objectMemory' 'coInterpreter' 'heapMap') includes: aString!
Item was removed:
- ----- Method: StackInterpreter class>>shouldGenerateTypedefFor: (in category 'translation') -----
- shouldGenerateTypedefFor: aStructClass
- "Hack to work-around mutliple definitions. Sometimes a type has been defined in an include."
- ^aStructClass ~~ VMCallbackContext!
Item was changed:
----- Method: StackInterpreter class>>writeVMHeaderTo:bytesPerWord: (in category 'translation') -----
writeVMHeaderTo: aStream bytesPerWord: bytesPerWord
super writeVMHeaderTo: aStream bytesPerWord: bytesPerWord.
NewspeakVM ifTrue:
[aStream nextPutAll: '#define NewspeakVM 1'; cr].
IMMUTABILITY ifTrue:
[aStream nextPutAll: '#define IMMUTABILITY 1'; cr].
NewspeakVM | IMMUTABILITY ifTrue:
[aStream cr].
+ aStream nextPutAll: '#define STACKVM 1'; cr.
+ (initializationOptions at: #SpurObjectMemory ifAbsent: false) ifTrue:
+ [aStream nextPutAll: '#define SPURVM 1'; cr]!
- aStream nextPutAll: '#define STACKVM 1'; cr; cr!
Item was changed:
----- Method: StackInterpreter>>findSelectorOfMethod: (in category 'debug support') -----
findSelectorOfMethod: methArg
| meth classObj classDict classDictSize methodArray i |
(objectMemory addressCouldBeObj: methArg) ifFalse:
[^objectMemory nilObject].
+ (objectMemory isForwarded: methArg)
+ ifTrue: [meth := objectMemory followForwarded: methArg]
+ ifFalse: [meth := methArg].
- meth := (objectMemory isForwarded: methArg)
- ifTrue: [objectMemory followForwarded: methArg]
- ifFalse: [methArg].
(objectMemory isOopCompiledMethod: meth) ifFalse:
[^objectMemory nilObject].
classObj := self methodClassOf: meth.
(self addressCouldBeClassObj: classObj) ifTrue:
[classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: classObj.
classDictSize := objectMemory fetchWordLengthOf: classDict.
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i <= (classDictSize - SelectorStart)] whileTrue:
[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
[^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)].
i := i + 1]].
^objectMemory nilObject!
Item was changed:
----- Method: StackInterpreterPrimitives>>pathTo:using:followWeak: (in category 'object access primitives') -----
pathTo: goal using: stack followWeak: followWeak
"Trace objects and frames from the root, marking visited objects, pushing the current path on stack, until goal is found.
If found, unmark, leaving path in stack, and answer 0. Otherwise answer an error:
PrimErrBadArgument if stack is not an Array
PrimErrBadIndex if search overflows stack
PrimErrNotFound if goal cannot be found"
| current hdr index next stackSize stackp freeStartAtStart |
(objectMemory isArray: stack) ifFalse:
[^PrimErrBadArgument].
freeStartAtStart := objectMemory freeStart. "check no allocations during search"
objectMemory beRootIfOld: stack. "so no store checks are necessary on stack"
stackSize := objectMemory lengthOf: stack.
objectMemory mark: stack.
"no need. the current context is not reachable from the active process (suspendedContext is nil)"
"objectMemory mark: self activeProcess."
current := objectMemory specialObjectsOop.
objectMemory mark: current.
index := objectMemory lengthOf: current.
stackp := 0.
[[(index := index - 1) >= -1] whileTrue:
+ [(stackPages couldBeFramePointer: current)
+ ifTrue:
+ [next := index >= 0
+ ifTrue: [self field: index ofFrame: (self cCoerceSimple: current to: #'char *')]
- [next := (stackPages couldBeFramePointer: current)
- ifTrue:
- [index >= 0
- ifTrue: [self field: index ofFrame: current]
ifFalse: [objectMemory nilObject]]
+ ifFalse:
+ [index >= 0
+ ifTrue:
+ [hdr := objectMemory baseHeader: current.
+ next := (objectMemory isContextHeader: hdr)
- ifFalse:
- [index >= 0
- ifTrue:
- [hdr := objectMemory baseHeader: current.
- (objectMemory isContextHeader: hdr)
ifTrue: [self fieldOrSenderFP: index ofContext: current]
ifFalse: [objectMemory fetchPointer: index ofObject: current]]
+ ifFalse:
+ [next := objectMemory fetchClassOfNonImm: current]].
- ifFalse:
- [objectMemory fetchClassOfNonImm: current]].
(stackPages couldBeFramePointer: next)
ifTrue: [self assert: (self isFrame: next onPage: (stackPages stackPageFor: next))]
ifFalse: [self assert: (self checkOkayOop: next)].
next = goal ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory storePointer: stackp ofObject: stack withValue: current.
self pruneStack: stack stackp: stackp.
^0].
((objectMemory isNonIntegerObject: next)
and: [(stackPages couldBeFramePointer: next)
ifTrue: [(self frameIsMarked: next) not]
ifFalse:
[(objectMemory isMarked: next) not
and: [((objectMemory isPointers: next) or: [objectMemory isCompiledMethod: next])
and: [followWeak or: [(objectMemory isWeakNonImm: next) not]]]]])
ifTrue:
[stackp + 2 > stackSize ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory nilFieldsOf: stack.
^PrimErrBadIndex]. "PrimErrNoMemory ?"
objectMemory
storePointerUnchecked: stackp ofObject: stack withValue: current;
storePointerUnchecked: stackp + 1 ofObject: stack withValue: (objectMemory integerObjectOf: index).
stackp := stackp + 2.
(stackPages couldBeFramePointer: (self cCoerceSimple: next to: #'char *'))
ifTrue:
[self markFrame: next.
index := self fieldsInFrame: (self cCoerceSimple: next to: #'char *')]
ifFalse:
[hdr := objectMemory baseHeader: next.
objectMemory baseHeader: next put: (hdr bitOr: MarkBit).
(objectMemory isCompiledMethodHeader: hdr)
ifTrue: [index := (self literalCountOf: next) + LiteralStart]
ifFalse: [index := objectMemory lengthOf: next]].
current := next]].
current = objectMemory specialObjectsOop ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory nilFieldsOf: stack.
^PrimErrNotFound].
index := objectMemory integerValueOf: (objectMemory fetchPointer: stackp - 1 ofObject: stack).
current := objectMemory fetchPointer: stackp - 2 ofObject: stack.
stackp := stackp - 2] repeat!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveMakeEphemeron (in category 'system control primitives') -----
primitiveMakeEphemeron
"Turn the receiver into an ephemeron.
TEMPORARY. For testing ephemeron handling in the VM only.
Ephemerons should be instantiated from a suitable class."
<export: true>
+ <option: #SpurObjectMemory>
- <option: #Spur>
((objectMemory isNonImmediate: self stackTop)
and: [objectMemory isFixedSizePointerFormat: (objectMemory formatOf: self stackTop)]) ifFalse:
[^self primitiveFailFor: (argumentCount = 0
ifTrue: [PrimErrBadReceiver]
ifFalse: [PrimErrBadArgument])].
objectMemory
setFormatOf: self stackTop
to: objectMemory ephemeronFormat.
self pop: argumentCount!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveVMParameter (in category 'system control primitives') -----
(excessive size, no diff calculated)
Item was added:
+ ----- Method: TAssignmentNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ variable nodesDo: aBlock parent: self.
+ expression nodesDo: aBlock parent: self.
+ aBlock value: self value: parent!
Item was added:
+ ----- Method: TBraceCaseNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ caseLabels do:
+ [:node| node nodesDo: aBlock parent: self.].
+ cases do:
+ [:node| node nodesDo: aBlock parent: self].
+ aBlock value: self value: parent!
Item was added:
+ ----- Method: TCaseStmtNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ expression nodesDo: aBlock parent: self.
+ cases do: [:c| c nodesDo: aBlock parent: self].
+ aBlock value: self value: parent!
Item was added:
+ ----- Method: TConstantNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ aBlock value: self value: parent!
Item was changed:
Object subclass: #TMethod
+ instanceVariableNames: 'selector returnType args locals declarations primitive parseTree labels writtenToGlobalVarsCache complete export static sharedLabel sharedCase comment definingClass globalStructureBuildMethodHasFoo canAsmLabel mustAsmLabel properties extraVariableNumber'
- instanceVariableNames: 'selector returnType args locals declarations primitive parseTree labels writtenToGlobalVarsCache complete export static sharedLabel sharedCase comment definingClass globalStructureBuildMethodHasFoo canAsmLabel mustAsmLabel properties cascadeVariableNumber'
classVariableNames: 'CaseStatements'
poolDictionaries: ''
category: 'VMMaker-Translation to C'!
Item was removed:
- ----- Method: TMethod>>buildSwitchStmt: (in category 'transformations') -----
- buildSwitchStmt: aSendNode
- "Build a switch statement node for the given send of caseOf: or caseOf:otherwise:."
-
- ^TSwitchStmtNode new
- expression: aSendNode receiver
- cases: aSendNode args first
- otherwiseOrNil: (aSendNode args at: 2 ifAbsent: [nil])!
Item was added:
+ ----- Method: TMethod>>buildSwitchStmt:parent: (in category 'transformations') -----
+ buildSwitchStmt: aSendNode parent: parentNode
+ "Build a switch statement node for the given send of caseOf: or caseOf:otherwise:."
+ | switch |
+ switch := TSwitchStmtNode new
+ expression: aSendNode receiver
+ cases: aSendNode args first
+ otherwiseOrNil: (aSendNode args at: 2 ifAbsent: [nil]).
+ (aSendNode receiver isVariable or: [parentNode isStmtList]) ifFalse:
+ [switch switchVariable: (locals add: (self extraVariableName: 'switch'))].
+ ^switch!
Item was removed:
- ----- Method: TMethod>>cascadeVariableNumber (in category 'transformations') -----
- cascadeVariableNumber
- ^cascadeVariableNumber!
Item was changed:
----- Method: TMethod>>determineTypeFor:in: (in category 'C code generation') -----
+ determineTypeFor: aNode in: aCodeGen
+ aNode isSend ifTrue:
+ [aNode selector == #addressOf: ifTrue:
+ [^(self determineTypeFor: aNode args first in: aCodeGen)
+ ifNil: [#sqInt]
+ ifNotNil: [:type| type, (type last isLetter ifTrue: [' *'] ifFalse: ['*'])]].
+ (aNode selector == #at:
+ and: [aNode receiver isVariable]) ifTrue:
+ [(aCodeGen typeOfVariable: aNode receiver name) ifNotNil:
+ [:type|
+ ^type last = $*
+ ifTrue: [aCodeGen
+ extractTypeFor: aNode receiver name
+ fromDeclaration: type allButLast]
+ ifFalse: [type]]].
+ ^(aCodeGen methodNamed: aNode selector)
- determineTypeFor: aTParseNode in: aCCodeGenerator
- aTParseNode isSend ifTrue:
- [^(aCCodeGenerator methodNamed: aTParseNode selector)
ifNil: [#sqInt]
ifNotNil: [:method| method returnType]].
+ aNode isAssignment ifTrue:
+ [^self determineTypeFor: aNode expression in: aCodeGen].
- aTParseNode isAssignment ifTrue:
- [^self determineTypeFor: aTParseNode expression in: aCCodeGenerator].
self error: 'don''t know how to extract return type from this kind of node'!
Item was added:
+ ----- Method: TMethod>>extraVariableName: (in category 'initialization') -----
+ extraVariableName: root
+ extraVariableNumber := extraVariableNumber
+ ifNil: [0]
+ ifNotNil: [extraVariableNumber + 1].
+ ^root, extraVariableNumber printString!
Item was added:
+ ----- Method: TMethod>>extraVariableNumber (in category 'transformations') -----
+ extraVariableNumber
+ ^extraVariableNumber!
Item was added:
+ ----- Method: TMethod>>labels: (in category 'accessing') -----
+ labels: aCollection
+
+ labels := aCollection isSequenceable
+ ifTrue: [aCollection asOrderedCollection]
+ ifFalse: [aCollection asSortedCollection asOrderedCollection]!
Item was changed:
----- Method: TMethod>>newCascadeTempFor: (in category 'initialization') -----
newCascadeTempFor: aTParseNode
| varNode |
+ varNode := TVariableNode new setName: (self extraVariableName: 'cascade').
- cascadeVariableNumber := cascadeVariableNumber
- ifNil: [0]
- ifNotNil: [cascadeVariableNumber + 1].
- varNode := TVariableNode new setName: 'cascade', cascadeVariableNumber printString.
aTParseNode isLeaf ifFalse:
[declarations
at: varNode name
+ put: [:tm :cg| tm halt; determineTypeFor: aTParseNode in: cg]].
- put: [:tm :cg| tm determineTypeFor: aTParseNode in: cg]].
^varNode!
Item was changed:
----- Method: TMethod>>prepareMethodIn: (in category 'transformations') -----
prepareMethodIn: aCodeGen
"Record sends of builtin operators, map sends of the special selector dispatchOn:in:
with case statement nodes, and map sends of caseOf:[otherwise:] to switch statements.
Note: Only replaces top-level sends of dispatchOn:in: et al and caseOf:[otherwise:].
These must be top-level statements; they cannot appear in expressions.
As a hack also update the types of variables introduced to implement cascades correctly.
+ This has to be done at the same time as this is done, so why not piggy back here?"
+ | replacements |
+ extraVariableNumber ifNotNil:
- This has to be done at teh same time as this is done, so why not piggy back here?"
- | replacements |.
- cascadeVariableNumber ifNotNil:
[declarations keysAndValuesDo:
[:varName :decl|
decl isBlock ifTrue:
[self assert: ((varName beginsWith: 'cascade') and: [varName last isDigit]).
locals add: varName.
self declarationAt: varName
put: (decl value: self value: aCodeGen), ' ', varName]]].
replacements := IdentityDictionary new.
aCodeGen
pushScope: declarations
while:
+ [parseTree nodesWithParentsDo:
+ [:node :parent|
- [parseTree nodesDo:
- [:node|
node isSend ifTrue:
[(aCodeGen isBuiltinSelector: node selector)
ifTrue:
[node isBuiltinOperator: true.
"If a to:by:do:'s limit has side-effects, declare the limit variable, otherwise delete it from the args"
(node selector = #to:by:do:
and: [node args size = 4]) ifTrue:
[| limitExpr |
limitExpr := node args first.
(limitExpr anySatisfy:
[:subNode|
subNode isSend
and: [(aCodeGen isBuiltinSelector: subNode selector) not
and: [(subNode isStructSend: aCodeGen) not]]])
ifTrue: [locals add: node args last name]
ifFalse:
[node arguments: node args allButLast]]]
ifFalse:
[(CaseStatements includes: node selector) ifTrue:
[replacements at: node put: (self buildCaseStmt: node)].
(#(caseOf: #caseOf:otherwise:) includes: node selector) ifTrue:
+ [replacements at: node put: (self buildSwitchStmt: node parent: parent)]]].
- [replacements at: node put: (self buildSwitchStmt: node)]]].
((node isAssignment or: [node isReturn])
and: [node expression isSwitch]) ifTrue:
[replacements at: node put: (self transformSwitchExpression: node)]]].
replacements isEmpty ifFalse:
[parseTree := parseTree replaceNodesIn: replacements]!
Item was changed:
----- Method: TMethod>>superExpansionNodeFor:args: (in category 'inlining') -----
superExpansionNodeFor: aSelector args: argumentNodes
"Answer the expansion of a super send. Merge the super expansion's
locals, properties and comment into this method's properties."
(definingClass superclass lookupSelector: aSelector)
ifNil: [self error: 'superclass does not define super method']
ifNotNil:
[:superMethod| | superTMethod commonVars varMap |
superTMethod := superMethod methodNode asTranslationMethodOfClass: self class.
((argumentNodes allSatisfy: [:parseNode| parseNode isVariableNode])
and: [(argumentNodes asOrderedCollection collect: [:parseNode| parseNode key]) = superTMethod args]) ifFalse:
[self error: definingClass name, '>>',selector, ' args ~= ',
superTMethod definingClass name, '>>', aSelector,
(String with: $. with: Character cr),
'For super expansions to be translated correctly each argument must be a variable with the same name as the corresponding argument in the super method.'].
self mergePropertiesOfSuperMethod: superTMethod.
(commonVars := superTMethod locals intersection: self locals) notEmpty ifTrue:
[varMap := Dictionary new.
commonVars do:
[:k| varMap at: k put: (superTMethod unusedNamePrefixedBy: k avoiding: self allLocals)].
superTMethod renameVariablesUsing: varMap].
self assert: (superTMethod locals allSatisfy: [:var| (self locals includes: var) not]).
locals addAll: superTMethod locals.
superTMethod declarations keysAndValuesDo:
[:var :decl|
self declarationAt: var put: decl].
superTMethod comment ifNotNil:
[:superComment|
comment := comment
ifNil: [superComment]
ifNotNil: [superComment, comment]].
+ superTMethod extraVariableNumber ifNotNil:
- superTMethod cascadeVariableNumber ifNotNil:
[:scvn|
+ extraVariableNumber := extraVariableNumber ifNil: [scvn] ifNotNil: [:cvn| cvn + scvn]].
- cascadeVariableNumber := cascadeVariableNumber ifNil: [scvn] ifNotNil: [:cvn| cvn + scvn]].
superTMethod elideAnyFinalReturn.
^superTMethod parseTree]!
Item was added:
+ ----- Method: TParseNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ self subclassResponsibility!
Item was added:
+ ----- Method: TParseNode>>nodesWithParentsDo: (in category 'enumerating') -----
+ nodesWithParentsDo: aBlock
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ self nodesDo: aBlock parent: nil!
Item was added:
+ ----- Method: TReturnNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ expression nodesDo: aBlock parent: self.
+ aBlock value: self value: parent!
Item was changed:
----- Method: TSendNode>>emitCCodeAsFieldReferenceOn:level:generator: (in category 'C code generation') -----
emitCCodeAsFieldReferenceOn: aStream level: level generator: aCodeGen
"If appropriate, translate this message send as a pointer dereference"
+ | parenCount |
(self isStructSend: aCodeGen) ifFalse:
[^false].
+ parenCount := receiver isSend ifTrue: [2] ifFalse: [1].
+ aStream next: parenCount put: $(.
- aStream nextPut: $(.
receiver emitCCodeAsExpressionOn: aStream level: 0 generator: aCodeGen.
+ parenCount > 1 ifTrue:
+ [aStream nextPut: $)].
(receiver structTargetKind: aCodeGen) caseOf: {
[#pointer] -> [aStream nextPut: $-; nextPut: $>].
[#struct] -> [aStream nextPut: $.] }.
aStream nextPutAll: (aCodeGen cFunctionNameFor: selector).
arguments isEmpty ifFalse:
[self assert: arguments size = 1.
aStream nextPutAll: ' = '.
arguments first emitCCodeAsExpressionOn: aStream level: level generator: aCodeGen].
aStream nextPut: $).
^true!
Item was added:
+ ----- Method: TSendNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ receiver nodesDo: aBlock parent: self.
+ arguments do: [:arg| arg nodesDo: aBlock parent: self].
+ aBlock value: self value: parent!
Item was changed:
----- Method: TSendNode>>structTargetKind: (in category 'testing') -----
structTargetKind: aCodeGen
"Answer if the recever evaluates to a struct or struct pointer
and hence can be dereferenced using . or ->. Answer any of
#struct #pointer or nil. Right now we don't need or support
structure return so this method answers either #pointer or nil."
selector == #cCoerceSimple:to: ifTrue:
[^(VMStructType isTypePointerToStruct: arguments last value) ifTrue:
[#pointer]].
+ selector == #at: ifTrue:
+ [receiver isVariable ifTrue:
+ [(aCodeGen typeOfVariable: receiver name) ifNotNil:
+ [:type| | derefType |
+ type last = $* ifFalse:
+ [^receiver structTargetKind: aCodeGen].
+ (Smalltalk classNamed: (aCodeGen
+ extractTypeFor: receiver name
+ fromDeclaration: type allButLast)) ifNotNil:
+ [:class|
+ class isStructClass ifTrue:
+ [^#struct]]]].
+ (receiver structTargetKind: aCodeGen) ifNotNil:
+ [:kind| ^kind]].
+
^(aCodeGen selectorReturnsPointerToStruct: selector) ifTrue:
[#pointer]!
Item was added:
+ ----- Method: TStmtListNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ statements do: [:s| s nodesDo: aBlock parent: self.].
+ aBlock value: self value: parent!
Item was added:
+ ----- Method: TStmtListNode>>nodesDo:value: (in category 'enumerating') -----
+ nodesDo: aBlock value: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ statements do: [:s| s nodesDo: aBlock parent: self.].
+ aBlock value: self value: parent!
Item was added:
+ ----- Method: TStmtListNode>>renameLabelsForInliningInto: (in category 'inlining support') -----
+ renameLabelsForInliningInto: aTMethod
+ "TMethod already has a method for this; hijack it..."
+ | labels |
+ labels := OrderedCollection new.
+ self nodesDo:
+ [:node| node isLabel ifTrue: [labels add: node label]].
+ TMethod new
+ parseTree: self;
+ labels: labels;
+ renameLabelsForInliningInto: aTMethod!
Item was changed:
TParseNode subclass: #TSwitchStmtNode
+ instanceVariableNames: 'expression cases otherwiseOrNil switchVariable'
- instanceVariableNames: 'expression cases otherwiseOrNil'
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-Translation to C'!
!TSwitchStmtNode commentStamp: '<historical>' prior: 0!
I implement a Smalltalk
foo caseOf: { [IntegerConstant | GlobalVariable] -> [expr] }
statement converting it into a C switch statement. I make some effort to discover identical right-hand-side cases.!
Item was added:
+ ----- Method: TSwitchStmtNode>>emitCCodeAsExpressionOn:level:generator: (in category 'C code generation') -----
+ emitCCodeAsExpressionOn: aStream level: level generator: aCodeGen
+ "Emit the receiver as an if-the-else chain."
+ | varName n |
+ self assert: (expression isVariable or: [switchVariable notNil]).
+ aStream nextPut: $(.
+ switchVariable
+ ifNil: [varName := String streamContents: [:s| expression emitCCodeOn: s level: 0 generator: aCodeGen].
+ aStream nextPutAll: varName]
+ ifNotNil:
+ [varName := switchVariable.
+ aStream nextPut: $(; nextPutAll: varName; nextPutAll: ' = '.
+ expression emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen.
+ aStream nextPut: $)].
+ n := 0.
+ cases do:
+ [:tuple|
+ [:labels :case|
+ labels do:
+ [:label|
+ n > 0 ifTrue:
+ [aStream nextPutAll: varName].
+ aStream nextPutAll: ' == '.
+ label emitCCodeAsArgumentOn: aStream level: level + 1 generator: aCodeGen.
+ aStream nextPut: $).
+ aStream crtab: level + n + 1.
+ aStream nextPutAll: '? ('.
+ (TStmtListNode new setArguments: #() statements: case statements)
+ emitCCodeAsArgumentOn: aStream
+ level: level + 2
+ generator: aCodeGen.
+ aStream nextPut: $); crtab: level + n + 1; nextPutAll: ': ('.
+ n := n + 1]]
+ valueWithArguments: tuple].
+ otherwiseOrNil
+ ifNotNil: [otherwiseOrNil emitCCodeAsArgumentOn: aStream level: level + 1 generator: aCodeGen]
+ ifNil: [aStream nextPutAll: 'error("Case not found and no otherwise clause"), 0'].
+ aStream next: n - 1 put: $)!
Item was added:
+ ----- Method: TSwitchStmtNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ expression nodesDo: aBlock parent: self..
+ cases do:
+ [:pair|
+ pair first do: [:node| node nodesDo: aBlock parent: self.].
+ pair last nodesDo: aBlock parent: self.].
+ otherwiseOrNil ifNotNil:
+ [otherwiseOrNil nodesDo: aBlock parent: self].
+ aBlock value: self value: parent!
Item was added:
+ ----- Method: TSwitchStmtNode>>switchVariable (in category 'accessing') -----
+ switchVariable
+ "Answer the value of switchVariable"
+
+ ^ switchVariable!
Item was added:
+ ----- Method: TSwitchStmtNode>>switchVariable: (in category 'accessing') -----
+ switchVariable: anObject
+ "Set the value of switchVariable"
+
+ switchVariable := anObject!
Item was added:
+ ----- Method: TVariableNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ aBlock value: self value: parent!
Item was added:
+ ----- Method: VMClass class>>declareCAsOop:in: (in category 'translation') -----
+ declareCAsOop: arrayOfVariableNames in: aCCodeGenerator
+ "Declare the variables in arrayOfVariableNames with type representing position in object memory."
+
+ arrayOfVariableNames do:
+ [:varName| aCCodeGenerator var: varName type: #usqInt]!
Item was added:
+ ----- Method: VMClass class>>declareCAsUSqLong:in: (in category 'translation') -----
+ declareCAsUSqLong: arrayOfVariableNames in: aCCodeGenerator
+ "Declare the variables in arrayOfVariableNames with type representing position in object memory."
+
+ arrayOfVariableNames do:
+ [:varName| aCCodeGenerator var: varName type: #usqLong]!
Item was changed:
----- Method: VMClass class>>initializeMiscConstants (in category 'initialization') -----
initializeMiscConstants
"Falsify the `what type of VM is this?' flags that are defined in the various interp.h files,
or in the case of VMBIGENDIAN the various sqConfig.h files.
Subclass implementations need to include a super initializeMiscConstantsWith:."
+ | omc |
VMBIGENDIAN class. "Mention this for the benefit of CCodeGenerator>>emitCConstantsOn:"
self isInterpreterClass ifTrue:
[STACKVM := COGVM := COGMTVM := false].
+
+ omc := initializationOptions at: #ObjectMemory ifAbsent: nil.
- NewspeakVM := initializationOptions at: #NewspeakVM ifAbsent: [false].
initializationOptions
+ at: #SqueakV3ObjectMemory "the good ole default"
+ put: (omc
+ ifNil: [true]
+ ifNotNil: [(Smalltalk at: omc) inheritsFrom: ObjectMemory]);
+ at: #SpurObjectMemory "the new condender"
+ put: (omc
+ ifNil: [false]
+ ifNotNil: [(Smalltalk at: omc) inheritsFrom: SpurMemoryManager]).
+
+ NewspeakVM := initializationOptions at: #NewspeakVM ifAbsent: [false].
- at: #Spur
- put: ((initializationOptions at: #ObjectMemory ifAbsent: [])
- ifNil: [false]
- ifNotNil:
- [:objMemClassName|
- (Smalltalk at: objMemClassName) inheritsFrom: SpurMemoryManager]).
MULTIPLEBYTECODESETS := initializationOptions at: #MULTIPLEBYTECODESETS ifAbsent: [false].
"N.B. Not yet implemented."
IMMUTABILITY := initializationOptions at: #IMMUTABILITY ifAbsent: [false].
"These for scripts etc... Usually they should get set by an Interpreter class's initializeMiscConstantsWith:"
(initializationOptions includesKey: #STACKVM) ifTrue:
[STACKVM := initializationOptions at: #STACKVM].
(initializationOptions includesKey: #COGVM) ifTrue:
[COGVM := initializationOptions at: #COGVM].
(initializationOptions includesKey: #COGMTVM) ifTrue:
[COGMTVM := initializationOptions at: #COGMTVM]!
Item was changed:
----- Method: VMClass class>>shouldGenerateTypedefFor: (in category 'translation') -----
shouldGenerateTypedefFor: aStructClass
"Hack to work-around multiple definitions. Sometimes a type has been defined in an include."
+ ^aStructClass ~~ VMCallbackContext!
- ^true!
Item was changed:
----- Method: VMMaker>>buildCodeGeneratorForCogit: (in category 'generate sources') -----
buildCodeGeneratorForCogit: getAPIMethods
"Answer the code generator for translating the cogit."
| cg cogitClass cogitClasses apicg |
cg := self createCogitCodeGenerator.
cg vmClass: (cogitClass := self cogitClass).
{ cogitClass. self interpreterClass } do:
[:cgc|
(cgc respondsTo: #initializeWithOptions:)
ifTrue: [cgc initializeWithOptions: optionsDictionary]
ifFalse: [cgc initialize]].
cogitClasses := OrderedCollection new.
[cogitClasses addFirst: cogitClass.
cogitClass ~~ Cogit
and: [cogitClass inheritsFrom: Cogit]] whileTrue:
[cogitClass := cogitClass superclass].
cogitClasses addFirst: VMClass.
cogitClasses addAllLast: ((self cogitClass ancilliaryClasses: optionsDictionary) reject: [:class| class isStructClass]).
cogitClasses do: [:cgc| cg addClass: cgc].
+ cg addStructClasses: (cg structClassesForTranslationClasses: cogitClasses).
- (cg structClassesForTranslationClasses: cogitClasses) do:
- [:structClass| cg addStructClass: structClass].
getAPIMethods ifTrue:
[apicg := self buildCodeGeneratorForInterpreter: false.
cg apiMethods: apicg selectAPIMethods].
^cg!
Item was changed:
----- Method: VMMaker>>buildCodeGeneratorForInterpreter: (in category 'generate sources') -----
buildCodeGeneratorForInterpreter: getAPIMethods
"Answer the code generator for translating the interpreter."
| cg interpreterClass interpreterClasses apicg |
interpreterClasses := OrderedCollection new.
+ interpreterClass := self interpreterClass.
+ interpreterClass initializeWithOptions: optionsDictionary.
- (cg := self createCodeGenerator) vmClass: (interpreterClass := self interpreterClass).
+ (cg := self createCodeGenerator) vmClass: interpreterClass.
+
[interpreterClass ~~ VMClass] whileTrue:
[interpreterClasses addFirst: interpreterClass.
interpreterClass := interpreterClass superclass].
cg vmClass objectMemoryClass ifNotNil:
[:objectMemoryClass|
interpreterClass := objectMemoryClass.
[interpreterClass ~~ VMClass] whileTrue:
[interpreterClasses addFirst: interpreterClass.
interpreterClass := interpreterClass superclass]].
interpreterClasses addFirst: VMClass.
+ interpreterClasses addAllLast: (cg nonStructClassesForTranslationClasses: interpreterClasses).
- interpreterClasses addAllLast: (((self interpreterClass ancilliaryClasses: optionsDictionary) reject: [:class| class isStructClass]) copyWithout: cg vmClass objectMemoryClass).
(cg structClassesForTranslationClasses: interpreterClasses) do:
+ [:structClass| structClass initialize].
+ cg addStructClasses: (cg structClassesForTranslationClasses: interpreterClasses).
- [:structClass|
- structClass initialize.
- cg addStructClass: structClass].
interpreterClasses do:
[:ic|
(ic respondsTo: #initializeWithOptions:)
ifTrue: [ic initializeWithOptions: optionsDictionary]
ifFalse: [ic initialize]].
interpreterClasses do: [:ic| cg addClass: ic].
(getAPIMethods
and: [self interpreterClass needsCogit]) ifTrue:
[apicg := self buildCodeGeneratorForCogit: false.
cg apiMethods: apicg selectAPIMethods].
^cg!
More information about the Vm-dev
mailing list