Vm-dev October 2013

vm-dev@lists.squeakfoundation.org

30 participants
145 discussions

VM Maker: VMMaker.oscog-eem.454.mcz
by commits＠source.squeak.org 14 Oct '13

14 Oct '13

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!

1 0

VM Maker: VMMaker.oscog-eem.453.mcz
by commits＠source.squeak.org 12 Oct '13

12 Oct '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.453.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.453 Author: eem Time: 11 October 2013, 5:19:39.495 pm UUID: 1510990d-a971-41cc-8a66-bc65a160454a Ancestors: VMMaker.oscog-eem.452 Oops. Some stragglers. Now gcc3x-interp.c is generated for StackInterpreter + Spur. =============== Diff against VMMaker.oscog-eem.452 =============== Item was added: + ----- Method: Spur32BitMMLESimulator>>isNonIntegerObject: (in category 'object testing') ----- + isNonIntegerObject: oop + "This list records the valid senders of isNonIntegerObject: as we replace uses of + isNonIntegerObject: by isNonImmediate: where appropriate." + (#( on:do: "from the dbeugger" + reverseDisplayFrom:to: + primitiveObjectAtPut + isCogMethodReference:) includes: thisContext sender method selector) ifFalse: + [self halt]. + ^super isNonIntegerObject: oop! Item was added: + ----- Method: SpurMemoryManager class>>additionalHeadersDo: (in category 'translation') ----- + additionalHeadersDo: aBinaryBlock + "Evaluate aBinaryBlock with the names and contents of + any additional header files that need to be generated."! Item was changed: ----- Method: SpurMemoryManager>>isNonIntegerObject: (in category 'object testing') ----- isNonIntegerObject: oop - "This list records the valid senders of isNonIntegerObject: as we replace uses of - isNonIntegerObject: by isNonImmediate: where appropriate." - (#( on:do: "from the dbeugger" - reverseDisplayFrom:to: - primitiveObjectAtPut - isCogMethodReference:) includes: thisContext sender method selector) ifFalse: - [self halt]. ^(oop bitAnd: 1) = 0!

1 0

VM Maker: VMMaker.oscog-eem.452.mcz
by commits＠source.squeak.org 12 Oct '13

12 Oct '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.452.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.452 Author: eem Time: 11 October 2013, 5:12:29.833 pm UUID: 1a0629f1-a8f6-4b4f-a0ab-0b93fe63cde0 Ancestors: VMMaker.oscog-eem.451 Add a configuration for a StackInterpreter+Spur VM. Make StackInterpreter + Spur translateable: - make BlockNode>>isPotentialCCaseLabelIn: not barf on [self arrayFormat] -> [...] et al - the usual class-side translation horrors added to SpurMemoryManager and subclasses - rename some args to avoid warnings about shadowing - Move the sender selector checking in isIntegerObject: et al down into the simulator subclasses. Round the CogVMSimulators heapBase to allocationUnit so the scavenger initializes correctly. Eliminate the bogus second initialization of obejctMemory in CogVMSimulator>>openOn:extraMemory:. Fix the assert in checkIfValidObjectRef:pc:cogMethod: since open pic linking can leave the selector unchanged in rare circumstances. Replicate the clasas-side fixes for intializationOptions in StackInterpreterSimulator in CogVMSimulator. =============== Diff against VMMaker.oscog-eem.451 =============== Item was removed: - ----- Method: BlockNode>>isPotentialCCaseLabel (in category '*VMMaker-C translation') ----- - isPotentialCCaseLabel - | stmt | - statements size ~= 1 ifTrue: [^false]. - stmt := statements first. - ^self isPotentialCCaseLabel: stmt! Item was removed: - ----- Method: BlockNode>>isPotentialCCaseLabel: (in category '*VMMaker-C translation') ----- - isPotentialCCaseLabel: stmt - (stmt isVariableNode - or: [stmt isLiteralNode - and: [stmt isConstantNumber or: [stmt literalValue isSymbol]]]) ifTrue: - [^true]. - stmt isMessageNode ifTrue: - [(#(* + -) includes: stmt selector key) ifTrue: - [^(self isPotentialCCaseLabel: stmt receiver) - and: [self isPotentialCCaseLabel: stmt arguments first]]. - ^stmt selector key = #asSymbol - and: [stmt receiver isLiteralNode - and: [stmt receiver literalValue isSymbol]]]. - ^false! Item was added: + ----- Method: BlockNode>>isPotentialCCaseLabel:in: (in category '*VMMaker-C translation') ----- + isPotentialCCaseLabel: stmt in: aTMethod + (stmt isVariableNode + or: [stmt isLiteralNode + and: [stmt isConstantNumber or: [stmt literalValue isSymbol]]]) ifTrue: + [^true]. + stmt isMessageNode ifTrue: + [| selector method | + selector := stmt selector key. + (#(* + -) includes: selector) ifTrue: + [^(self isPotentialCCaseLabel: stmt receiver in: aTMethod) + and: [self isPotentialCCaseLabel: stmt arguments first in: aTMethod]]. + + (selector = #asSymbol + and: [stmt receiver isLiteralNode + and: [stmt receiver literalValue isSymbol]]) ifTrue: + [^true]. + + (stmt arguments isEmpty + and: [method := (aTMethod definingClass whichClassIncludesSelector: selector) >> selector. + (method isQuick + or: [(method literalAt: 1) isInteger + and: [method numLiterals = 3]]) + and: [(aTMethod definingClass basicNew perform: selector) isInteger]]) ifTrue: + [^true]]. + ^false! Item was added: + ----- Method: BlockNode>>isPotentialCCaseLabelIn: (in category '*VMMaker-C translation') ----- + isPotentialCCaseLabelIn: aTMethod + | stmt | + statements size ~= 1 ifTrue: [^false]. + stmt := statements first. + ^self isPotentialCCaseLabel: stmt in: aTMethod! Item was changed: ----- Method: BraceNode>>asTranslatorNodeIn: (in category '*VMMaker-C translation') ----- asTranslatorNodeIn: aTMethod "make a CCodeGenerator equivalent of me" self assert: (elements allSatisfy: [:elem| elem isMessageNode and: [elem selector key = #-> and: [elem receiver isBlockNode and: [elem arguments first isBlockNode + and: [elem receiver isPotentialCCaseLabelIn: aTMethod]]]]]). - and: [elem receiver isPotentialCCaseLabel]]]]]). ^TBraceCaseNode new caseLabels: (elements collect: [:elem| elem receiver asTranslatorNodeIn: aTMethod]); cases: (elements collect: [:elem| elem arguments first asTranslatorNodeIn: aTMethod]); comment: comment! Item was changed: ----- Method: CoInterpreter>>followForwardingPointersInStackZone: (in category 'object memory support') ----- + followForwardingPointersInStackZone: theBecomeEffectsFlags - followForwardingPointersInStackZone: becomeEffectsFlags "Spur's become: is lazy, turning the becommed object into a forwarding object to the other. The read-barrier is minimised by arranging that forwarding pointers will fail a method cache probe, since notionally objects' internals are accessed only via sending messages to them (the exception is primitives that access the internals of the non-receiver argument(s). To avoid a read barrier on bytecode, literal and inst var fetch we scan the receivers and methods in the stack zone and follow any forwarded ones. This is of course way cheaper than scanning all of memory as in the old become." | theIPPtr | <inline: false> <var: #thePage type: #'StackPage *'> <var: #theSP type: #'char *'> <var: #theFP type: #'char *'> <var: #callerFP type: #'char *'> <var: #theIPPtr type: #'char *'> + (theBecomeEffectsFlags anyMask: BecameCompiledMethodFlag) ifTrue: - (becomeEffectsFlags anyMask: BecameCompiledMethodFlag) ifTrue: [(objectMemory isForwarded: method) ifTrue: [theIPPtr := instructionPointer - method. method := objectMemory followForwarded: method. instructionPointer := method + theIPPtr]. (objectMemory isForwarded: newMethod) ifTrue: [newMethod := objectMemory followForwarded: newMethod]]. self assert: stackPage ~= 0. 0 to: numStackPages - 1 do: [:i| | thePage theSP theFP callerFP oop offset | thePage := stackPages stackPageAt: i. thePage isFree ifFalse: [theSP := thePage headSP. theFP := thePage headFP. "Skip the instruction pointer on top of stack of inactive pages." thePage = stackPage ifTrue: [theIPPtr := 0] ifFalse: [theIPPtr := theSP. theSP := theSP + BytesPerWord]. [self assert: (thePage addressIsInPage: theFP). self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr]). offset := theFP + (self frameStackedReceiverOffset: theFP). oop := stackPages longAt: offset. ((objectMemory isNonImmediate: oop) and: [(objectMemory isForwarded: oop)]) ifTrue: [stackPages longAt: offset put: (objectMemory followForwarded: oop)]. ((self frameHasContext: theFP) and: [(objectMemory isForwarded: (self frameContext: theFP))]) ifTrue: [stackPages longAt: theFP + FoxThisContext put: (objectMemory followForwarded: (self frameContext: theFP))]. (self isMachineCodeFrame: theFP) ifTrue: [oop := stackPages longAt: theFP + FoxIFReceiver. ((objectMemory isNonImmediate: oop) and: [(objectMemory isForwarded: oop)]) ifTrue: [stackPages longAt: theFP + FoxIFReceiver put: (objectMemory followForwarded: oop)]. self assert: (objectMemory isForwarded: (self frameMethodObject: theFP)) not] ifFalse: [oop := stackPages longAt: theFP + FoxIFReceiver. ((objectMemory isNonImmediate: oop) and: [(objectMemory isForwarded: oop)]) ifTrue: [stackPages longAt: theFP + FoxIFReceiver put: (objectMemory followForwarded: oop)]. oop := self frameMethod: theFP. (objectMemory isForwarded: oop) ifTrue: [| delta | delta := (objectMemory followForwarded: oop) - oop. (theIPPtr ~= 0 and: [(stackPages longAt: theIPPtr) > (self frameMethod: theFP)]) ifTrue: [stackPages longAt: theIPPtr put: (stackPages longAt: theIPPtr) + delta]. stackPages longAt: theFP + FoxIFSavedIP put: (stackPages longAt: theFP + FoxIFSavedIP) + delta. stackPages longAt: theFP + FoxMethod put: (objectMemory followForwarded: oop)]]. self followNecessaryForwardingInMethod: (self frameMethod: theFP). (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue: [theIPPtr := theFP + FoxCallerSavedIP. theFP := callerFP]]]! Item was changed: ----- Method: CoInterpreter>>postBecomeAction: (in category 'object memory support') ----- + postBecomeAction: theBecomeEffectsFlags - postBecomeAction: becomeEffectsFlags "Clear the gcMode var and let the Cogit do its post GC checks." + super postBecomeAction: theBecomeEffectsFlags. - super postBecomeAction: becomeEffectsFlags. cogit cogitPostGCAction: gcMode. lastCoggableInterpretedBlockMethod := lastUncoggableInterpretedBlockMethod := nil. gcMode := 0! Item was changed: ----- Method: CoInterpreterStackPages>>initializeStack:numSlots:pageSize: (in category 'initialization') ----- initializeStack: theStackPages numSlots: stackSlots pageSize: slotsPerPage "Initialize the stack pages. In the C VM theStackPages will be alloca'ed memory to hold the stack pages on the C stack. In the simulator they are housed in the memory between the cogMethodZone and the heap." <var: #theStackPages type: #'char *'> <returnTypeC: #void> | numPages page structStackPageSize pageStructBase count | <var: #page type: #'StackPage *'> <var: #pageStructBase type: #'char *'> self cCode: [] inSmalltalk: [self assert: objectMemory startOfMemory - coInterpreter cogCodeSize - coInterpreter methodCacheSize - coInterpreter primTraceLogSize - coInterpreter rumpCStackSize + = (stackSlots * BytesPerWord roundUpTo: objectMemory allocationUnit)]. - = (stackSlots * BytesPerWord)]. structStackPageSize := coInterpreter sizeof: InterpreterStackPage. bytesPerPage := slotsPerPage * BytesPerWord. numPages := coInterpreter numStkPages. "Because stack pages grow down baseAddress is at the top of a stack page and so to avoid subtracting BytesPerWord from baseAddress and lastAddress in the init loop below we simply push the stackPage array up one word to avoid the overlap. This word is extraStackBytes." pageStructBase := theStackPages + (numPages * bytesPerPage) + BytesPerWord. pages := self cCode: [self cCoerceSimple: pageStructBase to: #'StackPage *'] inSmalltalk: [pageMap := Dictionary new. ((0 to: numPages - 1) collect: [:i| InterpreterStackPage surrogateClass new address: pageStructBase + (i * structStackPageSize) simulator: coInterpreter zoneBase: coInterpreter stackZoneBase zoneLimit: objectMemory startOfMemory]) do: [:pageSurrogate| pageMap at: pageSurrogate address put: pageSurrogate]; yourself]. "make sure there's enough headroom" self assert: coInterpreter stackPageByteSize - coInterpreter stackLimitBytes - coInterpreter stackLimitOffset >= coInterpreter stackPageHeadroom. 0 to: numPages - 1 do: [:index| page := self stackPageAt: index. page lastAddress: theStackPages + (index * bytesPerPage); baseAddress: page lastAddress + bytesPerPage; stackLimit: page baseAddress - coInterpreter stackLimitBytes; realStackLimit: page stackLimit; baseFP: 0; nextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1])); prevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))]. "Now compute stackBasePlus1 so that the pageIndexFor: call maps all addresses from aPage baseAddress to aBase limitAddress + 1 to the same index (stacks grow down)" stackBasePlus1 := (self cCoerceSimple: theStackPages to: #'char *') + 1. self cCode: [] inSmalltalk: [minStackAddress := theStackPages. maxStackAddress := theStackPages + (numPages * bytesPerPage) + BytesPerWord - 1]. "The overflow limit is the amount of stack to retain when moving frames from an overflowing stack to reduce thrashing. See stackOverflowOrEvent:mayContextSwitch:" page := self stackPageAt: 0. overflowLimit := page baseAddress - page realStackLimit * 3 // 5. 0 to: numPages - 1 do: [:index| page := self stackPageAt: index. self assert: (self pageIndexFor: page baseAddress) == index. self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * BytesPerWord)) == index. self assert: (self stackPageFor: page baseAddress) == page. self assert: (self stackPageFor: page stackLimit) == page. self cCode: [] inSmalltalk: [| memIndex | memIndex := index * slotsPerPage + 1. "this is memIndex in the block above" self assert: (self memIndexFor: (self oopForPointer: page baseAddress)) == (memIndex + slotsPerPage - 1). index < (numPages - 1) ifTrue: [self assert: (self stackPageFor: page baseAddress + BytesPerWord) == (self stackPageAt: index + 1)]]. self assert: (page trace: -1) ~= 0 "for assert checking of the page tracing flags. -1 == invalid state"]. mostRecentlyUsedPage := self stackPageAt: 0. page := mostRecentlyUsedPage. count := 0. [| theIndex | count := count + 1. theIndex := self pageIndexFor: page baseAddress. self assert: (self stackPageAt: theIndex) == page. self assert: (self pageIndexFor: page baseAddress) == theIndex. self assert: (self pageIndexFor: page stackLimit) == theIndex. self assert: (self pageIndexFor: page lastAddress + 1) == theIndex. (page := page nextPage) ~= mostRecentlyUsedPage] whileTrue. self assert: count == numPages. self assert: self pageListIsWellFormed! Item was changed: ----- Method: CogVMSimulator class>>initializeWithOptions:objectMemoryClass: (in category 'class initialization') ----- initializeWithOptions: optionsDictionaryOrArray objectMemoryClass: objectMemoryClassOrNil "The relevant ObjectMemory, Interpreter and Cogit classes must be initialized in order. This happens notionally every time we start the simulator, but in fact happens when ever we instantiate a simulator." | cogitClassOrName | initializationOptions := optionsDictionaryOrArray isArray ifTrue: [Dictionary newFromPairs: optionsDictionaryOrArray] ifFalse: [optionsDictionaryOrArray]. (objectMemoryClassOrNil ifNil: [self objectMemoryClass]) initializeWithOptions: initializationOptions. + self initializeWithOptions: initializationOptions. + ((initializationOptions at: #COGMTVM ifAbsent: [false]) ifTrue: [CoInterpreterMT] ifFalse: [CoInterpreter]) initializeWithOptions: initializationOptions. (initializationOptions includesKey: #Cogit) ifTrue: [cogitClassOrName := initializationOptions at: #Cogit. cogitClassOrName isSymbol ifTrue: [cogitClassOrName := Smalltalk classNamed: cogitClassOrName]. CoInterpreter classPool at: #CogitClass put: cogitClassOrName]. (self cogitClass withAllSuperclasses copyUpTo: Cogit) reverseDo: [:c| c initializeWithOptions: initializationOptions]! Item was changed: ----- Method: CogVMSimulator class>>onObjectMemory:cogit:options: (in category 'instance creation') ----- onObjectMemory: anObjectMemory cogit: aCogit options: optionsDictionaryOrArray + | simulatorClass | ^self == CogVMSimulator ifTrue: + [simulatorClass := SmalltalkImage current endianness == #big - [self initializeWithOptions: optionsDictionaryOrArray - objectMemoryClass: (anObjectMemory ifNotNil: [anObjectMemory class]). - SmalltalkImage current endianness == #big ifTrue: [self notYetImplemented] + ifFalse: [CogVMSimulatorLSB]. + simulatorClass + initializeWithOptions: optionsDictionaryOrArray + objectMemoryClass: (anObjectMemory ifNotNil: [anObjectMemory class]). + simulatorClass + onObjectMemory: (anObjectMemory ifNil: + [self objectMemoryClass simulatorClass new]) + cogit: aCogit + options: optionsDictionaryOrArray] - ifFalse: [CogVMSimulatorLSB onObjectMemory: anObjectMemory cogit: aCogit options: optionsDictionaryOrArray]] ifFalse: [| sim | - self initializeWithOptions: optionsDictionaryOrArray. sim := self basicNew. sim objectMemory: anObjectMemory. sim cogit: aCogit. sim initialize. COGMTVM ifTrue: "Set via options" [sim initializeThreadSupport; initialize]. sim]! Item was changed: ----- Method: CogVMSimulator>>openOn:extraMemory: (in category 'initialization') ----- openOn: fileName extraMemory: extraBytes "CogVMSimulator new openOn: 'clone.im' extraMemory: 100000" | f version headerSize count heapSize oldBaseAddr bytesToShift swapBytes hdrNumStackPages hdrEdenBytes hdrCogCodeSize stackZoneSize methodCacheSize headerFlags primTraceLogSize firstSegSize hdrMaxExtSemTabSize | "open image file and read the header" ["begin ensure block..." f := FileStream readOnlyFileNamed: fileName. imageName := f fullName. f binary. version := self nextLongFrom: f. "current version: 16r1968 (=6504) vive la revolucion!!" (self readableFormat: version) ifTrue: [swapBytes := false] ifFalse: [(version := objectMemory byteSwapped: version) = self imageFormatVersion ifTrue: [swapBytes := true] ifFalse: [self error: 'incomaptible image format']]. headerSize := self getLongFromFile: f swap: swapBytes. heapSize := self getLongFromFile: f swap: swapBytes. "length of heap in file" oldBaseAddr := self getLongFromFile: f swap: swapBytes. "object memory base address of image" objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes). objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "Should be loaded from, and saved to the image header" savedWindowSize := self getLongFromFile: f swap: swapBytes. headerFlags := self getLongFromFile: f swap: swapBytes. self setImageHeaderFlagsFrom: headerFlags. extraVMMemory := self getLongFromFile: f swap: swapBytes. hdrNumStackPages := self getShortFromFile: f swap: swapBytes. "4 stack pages is small. Should be able to run with as few as three. 4 should be comfortable but slow. 8 is a reasonable default. Can be changed via vmParameterAt: 43 put: n" numStackPages := desiredNumStackPages ~= 0 ifTrue: [desiredNumStackPages] ifFalse: [hdrNumStackPages = 0 ifTrue: [self defaultNumStackPages] ifFalse: [hdrNumStackPages]]. desiredNumStackPages := hdrNumStackPages. stackZoneSize := self computeStackZoneSize. "This slot holds the size of the native method zone in 1k units. (pad to word boundary)." hdrCogCodeSize := (self getShortFromFile: f swap: swapBytes) * 1024. cogCodeSize := desiredCogCodeSize ~= 0 ifTrue: [desiredCogCodeSize] ifFalse: [hdrCogCodeSize = 0 ifTrue: [self defaultCogCodeSize] ifFalse: [hdrCogCodeSize]]. desiredCogCodeSize := hdrCogCodeSize. self assert: f position = 40. hdrEdenBytes := self getLongFromFile: f swap: swapBytes. objectMemory edenBytes: (desiredEdenBytes ~= 0 ifTrue: [desiredEdenBytes] ifFalse: [hdrEdenBytes = 0 ifTrue: [objectMemory defaultEdenBytes] ifFalse: [hdrEdenBytes]]). desiredEdenBytes := hdrEdenBytes. hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes. hdrMaxExtSemTabSize ~= 0 ifTrue: [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize]. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. Preserve it to be polite to other VMs." the2ndUnknownShort := self getShortFromFile: f swap: swapBytes. self assert: f position = 48. firstSegSize := self getLongFromFile: f swap: swapBytes. objectMemory firstSegmentSize: firstSegSize. "For Open PICs to be able to probe the method cache during simulation the methodCache must be relocated to memory." methodCacheSize := methodCache size * BytesPerWord. primTraceLogSize := primTraceLog size * BytesPerWord. "allocate interpreter memory. This list is in address order, low to high. In the actual VM the stack zone exists on the C stack." + heapBase := (cogCodeSize - heapBase := cogCodeSize + stackZoneSize + methodCacheSize + primTraceLogSize + + self rumpCStackSize) roundUpTo: objectMemory allocationUnit. - + self rumpCStackSize. objectMemory setHeapBase: heapBase memoryLimit: heapBase + heapSize + objectMemory newSpaceBytes + self interpreterAllocationReserveBytes + extraBytes endOfMemory: heapBase + heapSize. - objectMemory initialize. self assert: cogCodeSize \\ 4 = 0. self assert: objectMemory memoryLimit \\ 4 = 0. self assert: self rumpCStackSize \\ 4 = 0. "read in the image in bulk, then swap the bytes if necessary" f position: headerSize. objectMemory memory: ((cogit processor endianness == #little ifTrue: [LittleEndianBitmap] ifFalse: [Bitmap]) new: objectMemory memoryLimit // 4). count := objectMemory readHeapFromImageFile: f dataBytes: heapSize. count ~= heapSize ifTrue: [self halt]. ] ensure: [f close]. self moveMethodCacheToMemoryAt: cogCodeSize + stackZoneSize. self movePrimTraceLogToMemoryAt: cogCodeSize + stackZoneSize + methodCacheSize. self ensureImageFormatIsUpToDate: swapBytes. bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr. "adjust pointers for zero base address" Utilities informUser: 'Relocating object pointers...' during: [self initializeInterpreter: bytesToShift]. self initializeCodeGenerator! Item was changed: ----- Method: Cogit>>checkIfValidObjectRef:pc:cogMethod: (in category 'garbage collection') ----- checkIfValidObjectRef: annotation pc: mcpc cogMethod: cogMethod <var: #mcpc type: #'char *'> <var: #sendTable type: #'sqInt *'> annotation = IsObjectReference ifTrue: [| literal | literal := backEnd literalBeforeFollowingAddress: mcpc asInteger. (objectRepresentation checkValidObjectReference: literal) ifFalse: [coInterpreter print: 'object ref leak in CM '; printHex: cogMethod asInteger; print: ' @ '; printHex: mcpc asInteger; cr. ^1]]. (self isSendAnnotation: annotation) ifTrue: [| entryPoint selectorOrCacheTag offset sendTable | entryPoint := backEnd callTargetFromReturnAddress: mcpc asInteger. self offsetAndSendTableFor: entryPoint annotation: annotation into: [:off :table| offset := off. sendTable := table]. selectorOrCacheTag := backEnd inlineCacheTagAt: mcpc asInteger. (entryPoint > methodZoneBase + and: [offset ~= cmNoCheckEntryOffset + and: [(self cCoerceSimple: entryPoint + offset to: #'CogMethod *') cmType ~= CMOpenPIC + or: [(objectRepresentation couldBeObject: selectorOrCacheTag) not]]]) - and: [offset ~= cmNoCheckEntryOffset]) ifTrue: "linked non-super send, cacheTag is a cacheTag" [(objectRepresentation checkValidInlineCacheTag: selectorOrCacheTag) ifFalse: [coInterpreter print: 'cache tag leak in CM '; printHex: cogMethod asInteger; print: ' @ '; printHex: mcpc asInteger; cr. ^1]] ifFalse: "unlinked send or super send; cacheTag is a selector" [(objectRepresentation checkValidObjectReference: selectorOrCacheTag) ifFalse: [coInterpreter print: 'selector leak in CM '; printHex: cogMethod asInteger; print: ' @ '; printHex: mcpc asInteger; cr. ^1]]]. ^0 "keep scanning"! Item was added: + ----- Method: NewObjectMemory>>leakCheckNewSpaceGC (in category 'debug support') ----- + leakCheckNewSpaceGC + <api> + ^(checkForLeaks bitAnd: 2) ~= 0! Item was added: + ----- Method: Spur32BitCoMemoryManager class>>simulatorClass (in category 'simulation only') ----- + simulatorClass + ^Spur32BitMMLECoSimulator! Item was added: + ----- Method: Spur32BitMMLECoSimulator>>freeStart (in category 'accessing') ----- + freeStart + (#(Cogit SimpleStackBasedCogit StackToRegisterMappingCogit) includes: thisContext sender class name) ifTrue: + [self halt]. + ^super freeStart! Item was changed: ----- Method: Spur32BitMMLECoSimulator>>scavengingGCTenuringIf: (in category 'generation scavenging') ----- scavengingGCTenuringIf: tenuringCriterion "Run the scavenger." + "self halt: (statScavenges + 1) printString, ((statScavenges between: 9 and: 19) - self halt: (statScavenges + 1) printString, ((statScavenges between: 9 and: 19) ifTrue: ['th'] + ifFalse: [#('st' 'nd' 'rd') at: (statScavenges + 1) \\ 10 ifAbsent: 'th']), ' scavenge'." - ifFalse: [#('st' 'nd' 'rd') at: (statScavenges + 1) \\ 10 ifAbsent: 'th']), ' scavenge'. ^super scavengingGCTenuringIf: tenuringCriterion! Item was added: + ----- Method: Spur32BitMMLESimulator>>isIntegerObject: (in category 'object testing') ----- + isIntegerObject: oop + "This list records the valid senders of isIntegerObject: as we replace uses of + isIntegerObject: by isImmediate: where appropriate." + | sel | + sel := thisContext sender method selector. + (#( DoIt + DoItIn: + on:do: "from the debugger" + makeBaseFrameFor: + quickFetchInteger:ofObject: + frameOfMarriedContext: + objCouldBeClassObj: + isMarriedOrWidowedContext: + shortPrint: + bytecodePrimAt + bytecodePrimAtPut + commonAt: + commonAtPut: + loadFloatOrIntFrom: + positive32BitValueOf: + primitiveExternalCall + checkedIntegerValueOf: + bytecodePrimAtPut + commonAtPut: + primitiveVMParameter + checkIsStillMarriedContext:currentFP: + displayBitsOf:Left:Top:Right:Bottom: + fetchStackPointerOf: + primitiveContextAt + primitiveContextAtPut + subscript:with:storing:format: + printContext: + compare31or32Bits:equal: + signed64BitValueOf: + primDigitMultiply:negative: + digitLength: + isNegativeIntegerValueOf: + magnitude64BitValueOf: + primitiveMakePoint + primitiveAsCharacter + primitiveInputSemaphore + baseFrameReturn + primitiveExternalCall + primDigitCompare: + isLiveContext: + numPointerSlotsOf: + fileValueOf: + loadBitBltDestForm + fetchIntOrFloat:ofObject:ifNil: + fetchIntOrFloat:ofObject: + loadBitBltSourceForm + loadPoint:from: + primDigitAdd: + primDigitSubtract: + positive64BitValueOf: + digitBitLogic:with:opIndex: + signed32BitValueOf: + isNormalized: + primDigitDiv:negative: + bytesOrInt:growTo: + primitiveNewMethod + isCogMethodReference: + functionForPrimitiveExternalCall: + genSpecialSelectorArithmetic + genSpecialSelectorComparison + ensureContextHasBytecodePC: + instVar:ofContext: + ceBaseFrameReturn: + inlineCacheTagForInstance: + primitiveObjectAtPut + commonVariable:at:put:cacheIndex: + primDigitBitShiftMagnitude: + externalInstVar:ofContext:) includes: sel) ifFalse: + [self halt]. + ^super isIntegerObject: oop! Item was changed: + ----- Method: SpurMemoryManager class>>initBytesPerWord: (in category 'class initialization') ----- - ----- Method: SpurMemoryManager class>>initBytesPerWord: (in category 'initialization') ----- initBytesPerWord: nBytes BytesPerWord := nBytes. ShiftForWord := (BytesPerWord log: 2) rounded. "The following is necessary to avoid confusing the compiler with shifts that are larger than the width of the type on which they operate. In gcc, such shifts cause incorrect code to be generated." BytesPerWord = 8 ifTrue: "64-bit VM" [Byte0Mask := 16r00000000000000FF. Byte0Shift := 0. Byte1Mask := 16r000000000000FF00. Byte1Shift := 8. Byte2Mask := 16r0000000000FF0000. Byte2Shift := 16. Byte3Mask := 16r00000000FF000000. Byte3Shift := 24. Byte4Mask := 16r000000FF00000000. Byte4Shift := 32. Byte5Mask := 16r0000FF0000000000. Byte5Shift := 40. Byte6Mask := 16r00FF000000000000. Byte6Shift := 48. Byte7Mask := 16rFF00000000000000. Byte7Shift := 56. Bytes3to0Mask := 16r00000000FFFFFFFF. Bytes7to4Mask := 16rFFFFFFFF00000000] ifFalse: "32-bit VM" [Byte0Mask := 16r00000000000000FF. Byte0Shift := 0. Byte1Mask := 16r000000000000FF00. Byte1Shift := 8. Byte2Mask := 16r0000000000FF0000. Byte2Shift := 16. Byte3Mask := 16r00000000FF000000. Byte3Shift := 24. Byte4Mask := nil. Byte4Shift := 0. "unused" Byte5Mask := nil. Byte5Shift := 0. "unused" Byte6Mask := nil. Byte6Shift := 0. "unused" Byte7Mask := nil. Byte7Shift := 0. "unused" Bytes3to0Mask := nil. "unused" Bytes7to4Mask := nil "unused"]. Byte1ShiftNegated := Byte1Shift negated. Byte3ShiftNegated := Byte3Shift negated. Byte4ShiftNegated := Byte4Shift negated. Byte5ShiftNegated := Byte5Shift negated. Byte7ShiftNegated := Byte7Shift negated. "N.B. This is *not* output when generating the interpreter file. It is left to the various sqConfig.h files to define correctly." VMBIGENDIAN := Smalltalk endianness == #big! Item was changed: + ----- Method: SpurMemoryManager class>>initializeSpecialObjectIndices (in category 'class initialization') ----- - ----- Method: SpurMemoryManager class>>initializeSpecialObjectIndices (in category 'initialization') ----- initializeSpecialObjectIndices "Initialize indices into specialObjects array." NilObject := 0. FalseObject := 1. TrueObject := 2. SchedulerAssociation := 3. ClassBitmap := 4. ClassInteger := 5. ClassByteString := ClassString := 6. "N.B. Actually class ByteString" ClassArray := 7. "SmalltalkDictionary := 8." "Do not delete!!" ClassFloat := 9. ClassMethodContext := 10. "ClassBlockContext := 11. unused by the VM" ClassPoint := 12. ClassLargePositiveInteger := 13. TheDisplay := 14. ClassMessage := 15. "ClassCompiledMethod := 16. unused by the VM" TheLowSpaceSemaphore := 17. ClassSemaphore := 18. ClassCharacter := 19. SelectorDoesNotUnderstand := 20. SelectorCannotReturn := 21. ProcessSignalingLowSpace := 22. "was TheInputSemaphore" SpecialSelectors := 23. CharacterTable := nil. "Must be unused by the VM" SelectorMustBeBoolean := 25. ClassByteArray := 26. "ClassProcess := 27. unused" CompactClasses := 28. TheTimerSemaphore := 29. TheInterruptSemaphore := 30. SelectorCannotInterpret := 34. "Was MethodContextProto := 35." ClassBlockClosure := 36. "Was BlockContextProto := 37." ExternalObjectsArray := 38. ClassMutex := 39. "Was: ClassTranslatedMethod := 40." ProcessInExternalCodeTag := 40. TheFinalizationSemaphore := 41. ClassLargeNegativeInteger := 42. ClassExternalAddress := 43. ClassExternalStructure := 44. ClassExternalData := 45. ClassExternalFunction := 46. ClassExternalLibrary := 47. SelectorAboutToReturn := 48. SelectorRunWithIn := 49. SelectorAttemptToAssign := 50. "PrimErrTableIndex := 51. in Interpreter class>>initializePrimitiveErrorCodes" ClassAlien := 52. SelectorInvokeCallback := 53. ClassUnsafeAlien := 54. ClassWeakFinalizer := 55. ForeignCallbackProcess := 56. SelectorUnknownBytecode := 57. SelectorCounterTripped := 58! Item was added: + ----- Method: SpurMemoryManager class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') ----- + isNonArgumentImplicitReceiverVariableName: aString + ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager') includes: aString! Item was added: + ----- Method: SpurMemoryManager class>>mustBeGlobal: (in category 'translation') ----- + mustBeGlobal: var + "Answer if a variable must be global and exported. Used for inst vars that are accessed from VM support code." + + ^'checkForLeaks' = var! Item was added: + ----- Method: SpurMemoryManager class>>prepareToBeAddedToCodeGenerator: (in category 'translation') ----- + prepareToBeAddedToCodeGenerator: aCodeGen + "Remove the superclass methods we override." + self selectors do: + [:sel| + (superclass whichClassIncludesSelector: sel) ifNotNil: + [aCodeGen removeMethodForSelector: sel]]! Item was changed: ----- Method: SpurMemoryManager>>checkedIntegerValueOf: (in category 'simulation only') ----- checkedIntegerValueOf: intOop + <doNotGenerate> "hack around the CoInterpreter/ObjectMemory split refactoring" ^coInterpreter checkedIntegerValueOf: intOop! Item was changed: ----- Method: SpurMemoryManager>>freeStart (in category 'accessing') ----- freeStart - (#(Cogit SimpleStackBasedCogit StackToregisterMappingCogit) includes: thisContext sender class name) ifTrue: - [self halt]. ^freeStart! Item was changed: ----- Method: SpurMemoryManager>>isIntegerObject: (in category 'object testing') ----- isIntegerObject: oop - "This list records the valid senders of isIntegerObject: as we replace uses of - isIntegerObject: by isImmediate: where appropriate." - | sel | - sel := thisContext sender method selector. - (#( DoIt - DoItIn: - on:do: "from the debugger" - makeBaseFrameFor: - quickFetchInteger:ofObject: - frameOfMarriedContext: - objCouldBeClassObj: - isMarriedOrWidowedContext: - shortPrint: - bytecodePrimAt - bytecodePrimAtPut - commonAt: - commonAtPut: - loadFloatOrIntFrom: - positive32BitValueOf: - primitiveExternalCall - checkedIntegerValueOf: - bytecodePrimAtPut - commonAtPut: - primitiveVMParameter - checkIsStillMarriedContext:currentFP: - displayBitsOf:Left:Top:Right:Bottom: - fetchStackPointerOf: - primitiveContextAt - primitiveContextAtPut - subscript:with:storing:format: - printContext: - compare31or32Bits:equal: - signed64BitValueOf: - primDigitMultiply:negative: - digitLength: - isNegativeIntegerValueOf: - magnitude64BitValueOf: - primitiveMakePoint - primitiveAsCharacter - primitiveInputSemaphore - baseFrameReturn - primitiveExternalCall - primDigitCompare: - isLiveContext: - numPointerSlotsOf: - fileValueOf: - loadBitBltDestForm - fetchIntOrFloat:ofObject:ifNil: - fetchIntOrFloat:ofObject: - loadBitBltSourceForm - loadPoint:from: - primDigitAdd: - primDigitSubtract: - positive64BitValueOf: - digitBitLogic:with:opIndex: - signed32BitValueOf: - isNormalized: - primDigitDiv:negative: - bytesOrInt:growTo: - primitiveNewMethod - isCogMethodReference: - functionForPrimitiveExternalCall: - genSpecialSelectorArithmetic - genSpecialSelectorComparison - ensureContextHasBytecodePC: - instVar:ofContext: - ceBaseFrameReturn: - inlineCacheTagForInstance: - primitiveObjectAtPut - commonVariable:at:put:cacheIndex: - primDigitBitShiftMagnitude: - externalInstVar:ofContext:) includes: sel) ifFalse: - [self halt]. ^(oop bitAnd: 1) ~= 0! Item was changed: ----- Method: SpurMemoryManager>>possibleRootStoreInto: (in category 'store check') ----- possibleRootStoreInto: destObj - (#( storePointer:ofObject:withValue: - storePointer:ofForwarder:withValue: - inPlaceBecome:and:copyHashFlag:) includes: thisContext sender method selector) ifFalse: - [self halt]. (self isRemembered: destObj) ifFalse: [scavenger remember: destObj. self setIsRememberedOf: destObj to: true]! Item was changed: ----- Method: SpurMemoryManager>>setFreeOldSpaceStart: (in category 'snapshot') ----- + setFreeOldSpaceStart: newFreeOldSpaceStart - setFreeOldSpaceStart: freeStart "Set by the segment manager on parsing the image." + freeOldSpaceStart := newFreeOldSpaceStart! - freeOldSpaceStart := freeStart! Item was changed: ----- Method: StackInterpreter>>followForwardingPointersInStackZone: (in category 'object memory support') ----- + followForwardingPointersInStackZone: theBecomeEffectsFlags - followForwardingPointersInStackZone: becomeEffectsFlags "Spur's become: is lazy, turning the becommed object into a forwarding object to the other. The read-barrier is minimised by arranging that forwarding pointers will fail a method cache probe, since notionally objects' internals are accessed only via sending messages to them (the exception is primitives that access the internals of the non-receiver argument(s). To avoid a read barrier on bytecode, literal and inst var fetch we scan the receivers and methods in the stack zone and follow any forwarded ones. This is of course way cheaper than scanning all of memory as in the old become." | theIPPtr | <inline: false> <var: #thePage type: #'StackPage *'> <var: #theSP type: #'char *'> <var: #theFP type: #'char *'> <var: #callerFP type: #'char *'> <var: #theIPPtr type: #'char *'> + (theBecomeEffectsFlags anyMask: BecameCompiledMethodFlag) ifTrue: - (becomeEffectsFlags anyMask: BecameCompiledMethodFlag) ifTrue: [(objectMemory isForwarded: method) ifTrue: [theIPPtr := instructionPointer - method. method := objectMemory followForwarded: method. instructionPointer := method + theIPPtr]. (objectMemory isForwarded: newMethod) ifTrue: [newMethod := objectMemory followForwarded: newMethod]]. self assert: stackPage ~= 0. 0 to: numStackPages - 1 do: [:i| | thePage theSP theFP callerFP theIP oop | thePage := stackPages stackPageAt: i. thePage isFree ifFalse: [theSP := thePage headSP. theFP := thePage headFP. "Skip the instruction pointer on top of stack of inactive pages." thePage = stackPage ifTrue: [theIPPtr := 0] ifFalse: [theIPPtr := theSP. theSP := theSP + BytesPerWord]. [self assert: (thePage addressIsInPage: theFP). self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr]). oop := stackPages longAt: theFP + FoxReceiver. ((objectMemory isNonImmediate: oop) and: [(objectMemory isForwarded: oop)]) ifTrue: [stackPages longAt: theFP + FoxReceiver put: (objectMemory followForwarded: oop)]. theIP := theFP + (self frameStackedReceiverOffset: theFP). "reuse theIP; its just an offset here" oop := stackPages longAt: theIP. ((objectMemory isNonImmediate: oop) and: [(objectMemory isForwarded: oop)]) ifTrue: [stackPages longAt: theIP put: (objectMemory followForwarded: oop)]. ((self frameHasContext: theFP) and: [(objectMemory isForwarded: (self frameContext: theFP))]) ifTrue: [stackPages longAt: theFP + FoxThisContext put: (objectMemory followForwarded: (self frameContext: theFP))]. oop := self frameMethod: theFP. (objectMemory isForwarded: oop) ifTrue: [| delta | theIPPtr ~= 0 ifTrue: [self assert: (stackPages longAt: theIPPtr) > (self frameMethod: theFP). delta := (objectMemory followForwarded: oop) - oop. stackPages longAt: theIPPtr put: (stackPages longAt: theIPPtr) + delta]. stackPages longAt: theFP + FoxMethod put: (objectMemory followForwarded: oop)]. self followNecessaryForwardingInMethod: (self frameMethod: theFP). (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue: [theIPPtr := theFP + FoxCallerSavedIP. theFP := callerFP]]]! Item was changed: ----- Method: StackInterpreter>>objectMemory: (in category 'initialization') ----- objectMemory: anObjectMemory <doNotGenerate> + objectMemory ifNotNil: [self halt]. objectMemory := anObjectMemory! Item was changed: ----- Method: StackInterpreter>>postBecomeAction: (in category 'object memory support') ----- + postBecomeAction: theBecomeEffectsFlags + theBecomeEffectsFlags ~= 0 ifTrue: + [self followForwardingPointersInStackZone: theBecomeEffectsFlags]! - postBecomeAction: becomeEffectsFlags - becomeEffectsFlags ~= 0 ifTrue: - [self followForwardingPointersInStackZone: becomeEffectsFlags]! Item was added: + ----- Method: VMMaker class>>generate:with:to:platformDir:excluding: (in category 'utilities') ----- + generate: interpreterClass with: optionsPairsArray to: srcDirName platformDir: platDirName excluding: exclusions + "Generate the VM to the given target directory. Include only plugins in pluginList. + Example: + (VMMaker + generate: StackInterpreter + with: #(ObjectMemory Spur32BitMemoryManager) + to: (FileDirectory default directoryNamed: 'oscogvm/spurstacksrc') fullName + platformDir: (FileDirectory default directoryNamed: 'oscogvm/platforms') fullName + excluding: (InterpreterPlugin withAllSubclasses collect: [:ea| ea name]))." + (self makerFor: interpreterClass and: nil with: optionsPairsArray to: srcDirName platformDir: platDirName excluding: exclusions) generateEntire! Item was added: + ----- Method: VMMaker class>>generateSqueakSpurStackVM (in category 'configurations') ----- + generateSqueakSpurStackVM + "No primitives since we can use those for the Cog VM" + ^VMMaker + generate: StackInterpreter + with: #(ObjectMemory Spur32BitMemoryManager) + to: (FileDirectory default directoryNamed: 'oscogvm/spurstacksrc') fullName + platformDir: (FileDirectory default directoryNamed: 'oscogvm/platforms') fullName + excluding: (InterpreterPlugin withAllSubclasses collect: [:ea| ea name])!

1 0

Re: [Vm-dev] VM Maker: VMMaker.oscog-eem.451.mcz
by tim Rowledge 12 Oct '13

12 Oct '13

On 11-10-2013, at 10:19 PM, commits(a)source.squeak.org wrote: > Spur now loads an image and can evaluate 3+4 (needs Cog-eem.114 or later). Yay! You're done! tim -- tim Rowledge; tim(a)rowledge.org; http://www.rowledge.org/tim Fractured Idiom:- COGITO EGGO SUM - I think; therefore, I am a waffle

1 0

VM Maker: VMMaker.oscog-eem.451.mcz
by commits＠source.squeak.org 12 Oct '13

12 Oct '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.451.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.451 Author: eem Time: 11 October 2013, 3:18:08.922 pm UUID: b5e6b999-d2ef-4257-8624-97aab4e0c555 Ancestors: VMMaker.oscog-eem.450 An incendiary commit!! :-) Refactor snapshotCleanUp to extract bereaveAndNormalizeContextsAndFlushExternalPrimitives for the bootstrap which doesn't want to GC before snapshotting. Fix the StackInterpreterSimulator window border. Harmonize the code with CogVMSimulator. Rename markAndTraceMachineCodeForIncrementalGC to markAndTraceMachineCodeForNewSpaceGC, & leakCheckIncrementalGC to leakCheckNewSpaceGC. Assert-check there's enough reserve on scavenge. Initialize classTableIndex when setting classTableRootObj. Fix setting up free space in the bootstrap. Swizzle the fileds beyond the stack p[ointer in contexts on start-up via adding lastPointerOfWhileSwizzling:. remember to set-up new space variables on image load (initializeNewSpaceVariables). Make computeTenuringThreshold cope with a flushed futureSpace. Spur now loads an image and can evaluate 3+4 (needs Cog-eem.114 or later). =============== Diff against VMMaker.oscog-eem.450 =============== Item was changed: ----- Method: CogVMSimulator>>openAsMorphNoTranscript (in category 'UI') ----- openAsMorphNoTranscript "Open a morphic view on this simulation." + | localImageName borderWidth window | - | localImageName theWindow | localImageName := FileDirectory default localNameFor: imageName. + window := (SystemWindow labelled: 'Simulation of ' , localImageName) model: self. - theWindow := (SystemWindow labelled: 'Simulation of ' , localImageName) model: self. + window addMorph: (displayView := ImageMorph new image: displayForm) - theWindow addMorph: (displayView := ImageMorph new image: displayForm) frame: (0@0 corner: 1(a)0.95). + window addMorph: (PluggableTextMorph on: self - theWindow addMorph: (PluggableTextMorph on: self text: #byteCountText accept: nil readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely frame: (0(a)0.95 corner: 1@1). + borderWidth := [SystemWindow borderWidth] "Squeak 4.1" + on: MessageNotUnderstood + do: [:ex| 0]. "3.8" + borderWidth := borderWidth + window borderWidth. + window openInWorldExtent: (self desiredDisplayExtent + + (2 * borderWidth) + + (0@window labelHeight) - theWindow openInWorldExtent: (self desiredDisplayExtent - + (2 * theWindow borderWidth) - + (0@theWindow labelHeight) * (1(a)(1/0.95))) rounded! Item was added: + ----- Method: CogVMSimulator>>savedWindowSize (in category 'I/O primitives') ----- + savedWindowSize + ^savedWindowSize ifNil: [0]! Item was added: + ----- Method: CogVMSimulator>>shortPrintFrame: (in category 'debug printing') ----- + shortPrintFrame: theFP + self transcript ensureCr. + ^super shortPrintFrame: theFP! Item was removed: - ----- Method: Cogit>>markAndTraceMachineCodeForIncrementalGC (in category 'jit - api') ----- - markAndTraceMachineCodeForIncrementalGC - "Free any methods that refer to unmarked objects, unlinking sends to freed methods." - | pointer cogMethod | - <var: #cogMethod type: #'CogMethod *'> - objectMemory leakCheckIncrementalGC ifTrue: - [self assert: self allMachineCodeObjectReferencesValid]. - codeModified := false. - pointer := methodZone youngReferrers. - [pointer < methodZone zoneEnd] whileTrue: - [cogMethod := coInterpreter cCoerceSimple: (objectMemory longAt: pointer) to: #'CogMethod *'. - cogMethod cmRefersToYoung ifTrue: - [self assert: (self cogMethodDoesntLookKosher: cogMethod) = 0. - self assert: (cogMethod cmType = CMMethod - or: [cogMethod cmType = CMOpenPIC]). - (objectMemory isYoung: cogMethod selector) ifTrue: - [objectMemory markAndTrace: cogMethod selector]. - cogMethod cmType = CMMethod ifTrue: - [(objectMemory isYoung: cogMethod methodObject) ifTrue: - [objectMemory markAndTrace: cogMethod methodObject]. - self markYoungObjectsIn: cogMethod]]. - pointer := pointer + BytesPerWord]. - objectMemory leakCheckIncrementalGC ifTrue: - [self assert: self allMachineCodeObjectReferencesValid]. - codeModified ifTrue: "After updating oops in inline caches we need to flush the icache." - [processor flushICacheFrom: methodZoneBase to: methodZone limitZony asInteger]! Item was added: + ----- Method: Cogit>>markAndTraceMachineCodeForNewSpaceGC (in category 'jit - api') ----- + markAndTraceMachineCodeForNewSpaceGC + "Free any methods that refer to unmarked objects, unlinking sends to freed methods." + | pointer cogMethod | + <var: #cogMethod type: #'CogMethod *'> + objectMemory leakCheckNewSpaceGC ifTrue: + [self assert: self allMachineCodeObjectReferencesValid]. + codeModified := false. + pointer := methodZone youngReferrers. + [pointer < methodZone zoneEnd] whileTrue: + [cogMethod := coInterpreter cCoerceSimple: (objectMemory longAt: pointer) to: #'CogMethod *'. + cogMethod cmRefersToYoung ifTrue: + [self assert: (self cogMethodDoesntLookKosher: cogMethod) = 0. + self assert: (cogMethod cmType = CMMethod + or: [cogMethod cmType = CMOpenPIC]). + (objectMemory isYoung: cogMethod selector) ifTrue: + [objectMemory markAndTrace: cogMethod selector]. + cogMethod cmType = CMMethod ifTrue: + [(objectMemory isYoung: cogMethod methodObject) ifTrue: + [objectMemory markAndTrace: cogMethod methodObject]. + self markYoungObjectsIn: cogMethod]]. + pointer := pointer + BytesPerWord]. + objectMemory leakCheckIncrementalGC ifTrue: + [self assert: self allMachineCodeObjectReferencesValid]. + codeModified ifTrue: "After updating oops in inline caches we need to flush the icache." + [processor flushICacheFrom: methodZoneBase to: methodZone limitZony asInteger]! Item was changed: ----- Method: Cogit>>markAndTraceObjectsOrFreeMachineCode: (in category 'jit - api') ----- markAndTraceObjectsOrFreeMachineCode: inFullGC <api> inFullGC ifTrue: [self markAndTraceOrFreeMachineCodeForFullGC] + ifFalse: [self markAndTraceMachineCodeForNewSpaceGC]! - ifFalse: [self markAndTraceMachineCodeForIncrementalGC]! Item was changed: ----- Method: NewObjectMemory>>runLeakCheckerForFullGC: (in category 'debug support') ----- runLeakCheckerForFullGC: fullGCFlag <inline: false> (fullGCFlag ifTrue: [self leakCheckFullGC] + ifFalse: [self leakCheckNewSpaceGC]) ifTrue: - ifFalse: [self leakCheckIncrementalGC]) ifTrue: [fullGCFlag ifTrue: [coInterpreter reverseDisplayFrom: 0 to: 7] ifFalse: [coInterpreter reverseDisplayFrom: 8 to: 15]. self clearLeakMapAndMapAccessibleObjects. self assert: self checkHeapIntegrity. self assert: coInterpreter checkInterpreterIntegrity. self assert: coInterpreter checkStackIntegrity. self assert: (coInterpreter checkCodeIntegrity: fullGCFlag). self validate "simulation only"]! Item was changed: ----- Method: Spur32BitMMLESimulator>>scavengingGCTenuringIf: (in category 'generation scavenging') ----- scavengingGCTenuringIf: tenuringCriterion "Run the scavenger." + "self halt: (statScavenges + 1) printString, ((statScavenges between: 9 and: 19) - self halt: (statScavenges + 1) printString, ((statScavenges between: 9 and: 19) ifTrue: ['th'] + ifFalse: [#('st' 'nd' 'rd') at: (statScavenges + 1) \\ 10 ifAbsent: 'th']), ' scavenge'." - ifFalse: [#('st' 'nd' 'rd') at: (statScavenges + 1) \\ 10 ifAbsent: 'th']), ' scavenge'. ^super scavengingGCTenuringIf: tenuringCriterion! 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)]. - fractionSurvived := (futureSurvivorStart - futureSpace start) asFloat - / (futureSpace limit - futureSpace start). tenuringThreshold := fractionSurvived > 0.9 ifTrue: [((pastSpace limit - pastSpace start) * (1.0 - tenuringProportion)) rounded + pastSpace start] ifFalse: [0]! Item was changed: ----- Method: SpurMemoryManager>>characterValueOf: (in category 'immediates') ----- characterValueOf: oop "Immediate characters are unsigned" + ^oop asUnsignedInteger >> self numTagBits! - ^(self cCoerceSimple: oop to: #'unsigned long') >> self numTagBits! Item was changed: ----- Method: SpurMemoryManager>>classTableRootObj: (in category 'accessing') ----- classTableRootObj: anOop - "For mapInterpreterOops" classTableRootObj := anOop. classTableFirstPage := self fetchPointer: 0 ofObject: classTableRootObj. self assert: (self numSlotsOf: classTableRootObj) = (1 << (self classIndexFieldWidth - self classTableMajorIndexShift)). + self assert: (self numSlotsOf: classTableFirstPage) - 1 = self classTableMinorIndexMask. + "set classTableIndex to the start of the last used page" + 2 to: (self numSlotsOf: classTableRootObj) - 1 do: + [:i| + (self fetchPointer: i ofObject: classTableRootObj) = nilObj ifTrue: + [classTableIndex := i << self classTableMajorIndexShift. + ^self]]. + "no unused pages; set it to the start of the second page." + classTableIndex := 1 << self classTableMajorIndexShift! - self assert: (self numSlotsOf: classTableFirstPage) - 1 = self classTableMinorIndexMask! Item was added: + ----- Method: SpurMemoryManager>>findString: (in category 'debug support') ----- + findString: aCString + "Print the oops of all string-like things that have the same characters as aCString" + <api> + <var: #aCString type: #'char *'> + | cssz | + cssz := self strlen: aCString. + self allObjectsDo: + [:obj| + ((self isBytesNonImm: obj) + and: [(self lengthOf: obj) = cssz + and: [(self str: aCString n: (self pointerForOop: obj + BaseHeaderSize) cmp: cssz) = 0]]) ifTrue: + [coInterpreter printHex: obj; space; printOopShort: obj; cr]]! Item was changed: ----- Method: SpurMemoryManager>>initializeFreeSpacePostLoad: (in category 'snapshot') ----- initializeFreeSpacePostLoad: freeListObj "Reinitialize the free list info. The freeLists object needs to be swizzled because its neither a free, nor a pointer object. Free objects have already been swizzled in adjustAllOopsBy:" self assert: (self numSlotsOf: freeListObj) = self numFreeLists. self assert: (self formatOf: freeListObj) = (self wordSize = 4 ifTrue: [self firstLongFormat] ifFalse: [self sixtyFourBitIndexableFormat]). - segmentManager numSegments = 0 ifTrue: "true in Spur image bootstrap" - [^self]. - self halt. freeLists := self firstIndexableField: freeListObj. 0 to: self numFreeLists - 1 do: [:i| (freeLists at: i) ~= 0 ifTrue: [freeListsMask := freeListsMask bitOr: (1 << i). + segmentManager numSegments > 0 ifTrue: "false in Spur image bootstrap" - segmentManager numSegments > 0 ifTrue: [freeLists at: i put: (segmentManager swizzleObj: (freeLists at: i))]]]. totalFreeOldSpace := self totalFreeListBytes! Item was added: + ----- 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: scavenger eden! Item was changed: ----- Method: SpurMemoryManager>>initializeObjectMemory: (in category 'initialization') ----- initializeObjectMemory: bytesToShift "Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks." "Assume: image reader initializes the following variables: memory memoryLimit specialObjectsOop lastHash " <inline: false> | freeListObj | - self halt. segmentManager adjustSegmentSwizzlesBy: bytesToShift. "image may be at a different address; adjust oops for new location" self adjustAllOopsBy: bytesToShift. segmentManager numSegments > 0 "false if Spur image bootstrap" ifTrue: [specialObjectsOop := segmentManager swizzleObj: specialObjectsOop] ifFalse: [self assert: bytesToShift = 0]. "heavily used special objects" nilObj := self splObj: NilObject. falseObj := self splObj: FalseObject. trueObj := self splObj: TrueObject. "In Cog we insist that nil, true & false are next to each other (Cogit generates tighter conditional branch code as a result). In addition, Spur places the free lists and class table root page immediately following them." self assert: nilObj = newSpaceLimit. self assert: falseObj = (self objectAfter: nilObj). self assert: trueObj = (self objectAfter: falseObj). freeListObj := self objectAfter: trueObj. self classTableRootObj: (self objectAfter: freeListObj). self initializeFreeSpacePostLoad: freeListObj. segmentManager collapseSegmentsPostSwizzle. + + self initializeNewSpaceVariables. - . self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart" "lowSpaceThreshold := 0. signalLowSpace := false. remapBufferCount := 0. tenuringThreshold := 2000. ""tenure all suriving objects if survivor count is over this threshold"" growHeadroom := 4*1024*1024. ""four megabytes of headroom when growing"" shrinkThreshold := 8*1024*1024. ""eight megabytes of free space before shrinking"" ""garbage collection statistics"" statFullGCs := 0. statFullGCUsecs := 0. statIncrGCs := 0. statIncrGCUsecs := 0. statTenures := 0. statRootTableOverflows := 0. statGrowMemory := 0. statShrinkMemory := 0. forceTenureFlag := 0. gcBiasToGrow := 0. gcBiasToGrowGCLimit := 0. extraRootCount := 0."! Item was added: + ----- Method: SpurMemoryManager>>lastPointerOfWhileSwizzling: (in category 'snapshot') ----- + lastPointerOfWhileSwizzling: objOop + "Answer the byte offset of the last pointer field of the given object. + Works with CompiledMethods, as well as ordinary objects. + Does not examine the stack pointer of contexts to be sure to swizzle + the nils that fill contexts on snapshot." + <api> + <inline: true> + <asmLabel: false> + | fmt numLiterals | + fmt := self formatOf: objOop. + self assert: fmt ~= self forwardedFormat. + fmt <= self lastPointerFormat ifTrue: + [^(self numSlotsOf: objOop) - 1 * BytesPerOop + self baseHeaderSize "all pointers"]. + fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers" + + "CompiledMethod: contains both pointers and bytes" + numLiterals := coInterpreter literalCountOf: objOop. + ^numLiterals + LiteralStart - 1 * BytesPerOop + self baseHeaderSize! Item was changed: ----- Method: SpurMemoryManager>>leakCheckFullGC (in category 'debug support') ----- leakCheckFullGC <api> ^(checkForLeaks bitAnd: 1) ~= 0! Item was added: + ----- Method: SpurMemoryManager>>leakCheckNewSpaceGC (in category 'debug support') ----- + leakCheckNewSpaceGC + <api> + ^(checkForLeaks bitAnd: 2) ~= 0! Item was removed: - ----- Method: SpurMemoryManager>>leakCheckScavenge (in category 'debug support') ----- - leakCheckScavenge - <api> - ^(checkForLeaks bitAnd: 2) ~= 0! Item was changed: ----- Method: SpurMemoryManager>>runLeakCheckerForFullGC: (in category 'debug support') ----- runLeakCheckerForFullGC: fullGCFlag <inline: false> (fullGCFlag ifTrue: [self leakCheckFullGC] + ifFalse: [self leakCheckNewSpaceGC]) ifTrue: - ifFalse: [self leakCheckScavenge]) ifTrue: [fullGCFlag ifTrue: [coInterpreter reverseDisplayFrom: 0 to: 7] ifFalse: [coInterpreter reverseDisplayFrom: 8 to: 15]. self clearLeakMapAndMapAccessibleObjects. self assert: self checkHeapIntegrity. self assert: coInterpreter checkInterpreterIntegrity. self assert: coInterpreter checkStackIntegrity. self assert: (coInterpreter checkCodeIntegrity: fullGCFlag)]! 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. 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: 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>>setHeapBase:memoryLimit:endOfMemory: (in category 'snapshot') ----- setHeapBase: heapBase memoryLimit: memLimit endOfMemory: memEnd + "Transcript - Transcript cr; nextPutAll: 'heapBase: '; print: heapBase; nextPut: $/; nextPutAll: heapBase hex; nextPutAll: ' memLimit '; print: memLimit; nextPut: $/; nextPutAll: memLimit hex; + nextPutAll: ' memEnd '; print: memEnd; nextPut: $/; nextPutAll: memEnd hex; cr; flush." - nextPutAll: ' memEnd '; print: memEnd; nextPut: $/; nextPutAll: memEnd hex; cr; flush. newSpaceLimit := heapBase + self newSpaceBytes + coInterpreter interpreterAllocationReserveBytes. freeOldSpaceStart := memEnd. endOfMemory := memLimit. scavenger newSpaceStart: heapBase newSpaceBytes: newSpaceLimit - heapBase edenBytes: newSpaceLimit - heapBase * (self scavengerDenominator - self numSurvivorSpaces) // self scavengerDenominator. freeStart := scavenger eden start. pastSpaceStart := scavenger pastSpace start! Item was changed: ----- Method: SpurMemoryManager>>swizzleFieldsOfObject: (in category 'snapshot') ----- swizzleFieldsOfObject: oop | fieldAddr fieldOop | <inline: true> + fieldAddr := oop + (self lastPointerOfWhileSwizzling: oop). - fieldAddr := oop + (self lastPointerOf: oop). [self oop: fieldAddr isGreaterThanOrEqualTo: oop + self baseHeaderSize] whileTrue: [fieldOop := self longAt: fieldAddr. (self isNonImmediate: fieldOop) ifTrue: [self longAt: fieldAddr put: (segmentManager swizzleObj: fieldOop)]. fieldAddr := fieldAddr - BytesPerOop]! Item was added: + ----- Method: StackInterpreter>>bereaveAndNormalizeContextsAndFlushExternalPrimitives (in category 'image save/restore') ----- + bereaveAndNormalizeContextsAndFlushExternalPrimitives + "Clean up right before saving an image, sweeping memory and: + * nilling out all fields of contexts above the stack pointer + * bereaving widowed contexts. + * flushing external primitives. + By ensuring that all contexts are single in a snapshot (i.e. that no married contexts + exist) we can maintain the invariant that a married or widowed context's frame + reference (in its sender field) must point into the stack pages since no married or + widowed contexts are present from older runs of the system." + objectMemory allObjectsDo: + [:obj| | header fmt sz | + header := self longAt: obj. + fmt := objectMemory formatOfHeader: header. + "Clean out context" + (fmt = objectMemory indexablePointersFormat + and: [objectMemory isContextHeader: header]) ifTrue: + ["All contexts have been divorced. Bereave remaining widows." + (self isMarriedOrWidowedContext: obj) ifTrue: + [self markContextAsDead: obj]. + "Fill slots beyond top of stack with nil" + (self fetchStackPointerOf: obj) + CtxtTempFrameStart + to: (objectMemory numSlotsOf: obj) - 1 + do: [:i | + objectMemory + storePointerUnchecked: i + ofObject: obj + withValue: objectMemory nilObject]]. + "Clean out external functions from compiled methods" + fmt >= objectMemory firstCompiledMethodFormat ifTrue: + ["Its primitiveExternalCall" + (self primitiveIndexOf: obj) = PrimitiveExternalCallIndex ifTrue: + [self flushExternalPrimitiveOf: obj]]].! Item was changed: ----- Method: StackInterpreter>>snapshotCleanUp (in category 'image save/restore') ----- snapshotCleanUp "Clean up right before saving an image, garbage collecting, sweeping memory and: + * nilling out all fields of contexts above the stack pointer. + * flushing external primitives + * bereaving widowed contexts + * clearing the root bit of any object in the root table. - * nilling out all fields of contexts above the stack pointer. - * flushing external primitives - * clearing the root bit of any object in the root table - * bereaving widowed contexts. By ensuring that all contexts are single in a snapshot (i.e. that no married contexts exist) we can maintain the invariant that a married or widowed context's frame reference (in its sender field) must point into the stack pages since no married or widowed contexts are present from older runs of the system." objectMemory hasSpurMemoryManagerAPI ifTrue: [objectMemory flushNewSpace] ifFalse: [objectMemory incrementalGC]. "compact memory and compute the size of the memory actually in use" "maximimize space for forwarding table" objectMemory fullGC. + self bereaveAndNormalizeContextsAndFlushExternalPrimitives. - objectMemory allObjectsDo: - [:obj| | header fmt sz | - header := self longAt: obj. - fmt := objectMemory formatOfHeader: header. - "Clean out context" - (fmt = objectMemory indexablePointersFormat - and: [objectMemory isContextHeader: header]) ifTrue: - ["All contexts have been divorced. Bereave remaining widows." - (self isMarriedOrWidowedContext: obj) ifTrue: - [self markContextAsDead: obj]. - "Fill slots beyond top of stack with nil" - (self fetchStackPointerOf: obj) + CtxtTempFrameStart - to: (objectMemory numSlotsOf: obj) - 1 - do: [:i | - objectMemory - storePointerUnchecked: i - ofObject: obj - withValue: objectMemory nilObject]]. - "Clean out external functions from compiled methods" - fmt >= objectMemory firstCompiledMethodFormat ifTrue: - ["Its primitiveExternalCall" - (self primitiveIndexOf: obj) = PrimitiveExternalCallIndex ifTrue: - [self flushExternalPrimitiveOf: obj]]]. objectMemory hasSpurMemoryManagerAPI ifFalse: [objectMemory clearRootsTable]! Item was changed: ----- Method: StackInterpreterSimulator>>openAsMorph (in category 'UI') ----- openAsMorph "Open a morphic view on this simulation." + | localImageName borderWidth window | - | window localImageName | localImageName := imageName ifNotNil: [FileDirectory default localNameFor: imageName] ifNil: [' synthetic image']. window := (SystemWindow labelled: 'Simulation of ', localImageName) model: self. window addMorph: (displayView := ImageMorph new image: displayForm) frame: (0@0 corner: 1(a)0.8). transcript := TranscriptStream on: (String new: 10000). window addMorph: (PluggableTextMorph on: transcript text: nil accept: nil readSelection: nil menu: #codePaneMenu:shifted:) frame: (0(a)0.8 corner: 0.7@1). - window addMorph: (PluggableTextMorph on: self text: #byteCountText accept: nil readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely frame: (0.7(a)0.8 corner: 1@1). + borderWidth := [SystemWindow borderWidth] "Squeak 4.1" + on: MessageNotUnderstood + do: [:ex| 0]. "3.8" + borderWidth := borderWidth + window borderWidth. window openInWorldExtent: (self desiredDisplayExtent + + (2 * borderWidth) - + (2 * window borderWidth) + (0@window labelHeight) * (1(a)(1/0.8))) rounded. ^window! Item was changed: ----- Method: StackInterpreterSimulator>>openAsMorphNoTranscript (in category 'UI') ----- openAsMorphNoTranscript "Open a morphic view on this simulation." + | localImageName borderWidth window | - | window localImageName | localImageName := FileDirectory default localNameFor: imageName. window := (SystemWindow labelled: 'Simulation of ' , localImageName) model: self. window addMorph: (displayView := ImageMorph new image: displayForm) frame: (0@0 corner: 1(a)0.95). window addMorph: (PluggableTextMorph on: self + text: #byteCountText accept: nil + readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely - text: #byteCountText accept: nil) hideScrollBarsIndefinitely frame: (0(a)0.95 corner: 1@1). + borderWidth := [SystemWindow borderWidth] "Squeak 4.1" + on: MessageNotUnderstood + do: [:ex| 0]. "3.8" + borderWidth := borderWidth + window borderWidth. window openInWorldExtent: (self desiredDisplayExtent + + (2 * borderWidth) - + (2 * window borderWidth) + (0@window labelHeight) * (1(a)(1/0.95))) rounded! Item was added: + ----- Method: StackInterpreterSimulator>>savedWindowSize (in category 'I/O primitives') ----- + savedWindowSize + ^savedWindowSize ifNil: [0]! Item was added: + ----- Method: StackInterpreterSimulator>>setDisplayForm: (in category 'spur bootstrap') ----- + setDisplayForm: aForm + displayForm := aForm! Item was added: + ----- Method: StackInterpreterSimulator>>shortPrintFrame: (in category 'debug printing') ----- + shortPrintFrame: theFP + self transcript ensureCr. + ^super shortPrintFrame: theFP!

1 0

VM Maker: Cog-eem.114.mcz
by commits＠source.squeak.org 12 Oct '13

12 Oct '13

Eliot Miranda uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog-eem.114.mcz ==================== Summary ==================== Name: Cog-eem.114 Author: eem Time: 11 October 2013, 3:07:14.576 pm UUID: f73eade5-3f36-4cd6-af32-ce83511bde41 Ancestors: Cog-eem.113 Spur bootstrap: Add an efficient Character>>= method (#=='s primitive). Turn off leak checking of the scavenger in the bootstrap. Use the newly-minted bereaveAndNormalizeContextsAndFlushExternalPrimitives to make sure the snapshot of the transformed image has no invalid external function indices. =============== Diff against Cog-eem.113 =============== Item was added: + ----- Method: SpurBootstrap class>>CharacterPROTOTYPEDollarEquals: (in category 'method prototypes') ----- + CharacterPROTOTYPEDollarEquals: aCharacter + "Primitive. Answer if the receiver and the argument are the + same object (have the same object pointer). Optional. See + Object documentation whatIsAPrimitive." + <primitive: 110> + ^self == aCharacter! Item was changed: ----- Method: SpurBootstrap>>launch:simulatorClass:headerFlags: (in category 'testing') ----- launch: heap simulatorClass: simulatorClass headerFlags: headerFlags | sim methodCacheSize | sim := simulatorClass onObjectMemory: heap. heap coInterpreter: sim. (sim class allInstVarNames includes: 'cogCodeSize') ifTrue: [sim initializeInterpreter: 0. methodCacheSize := sim methodCache size * heap wordSize. sim instVarNamed: 'heapBase' put: heap startOfMemory; instVarNamed: 'numStackPages' put: 8; instVarNamed: 'cogCodeSize' put: 1024*1024; moveMethodCacheToMemoryAt: sim cogCodeSize + sim computeStackZoneSize; movePrimTraceLogToMemoryAt: sim cogCodeSize + sim computeStackZoneSize + methodCacheSize; "sendTrace: 1+ 2 + 8 + 16;" initializeCodeGenerator] ifFalse: [sim initializeInterpreter: 0]. sim setImageHeaderFlagsFrom: headerFlags; imageName: ImageName; flushExternalPrimitives; openAsMorph; transcript: Transcript. "deep copy copies this" "sim instVarNamed: 'printSends' put: true; instVarNamed: 'printReturns' put: true; instVarNamed: 'methodDictLinearSearchLimit' put: SmallInteger maxVal." "for now" heap + setCheckForLeaks: 0; - setCheckForLeaks: 15; runLeakCheckerForFullGC: true. sim halt; run! Item was changed: ----- Method: SpurBootstrap>>on: (in category 'initialize-release') ----- on: imageName StackInterpreter initializeWithOptions: Dictionary new. oldInterpreter := StackInterpreterSimulator new. oldInterpreter openOn: imageName extraMemory: 0. oldHeap := oldInterpreter objectMemory. newHeap := Spur32BitMMLESimulator new. newHeap allocateMemoryOfSize: (oldHeap youngStart * 3 / 2 roundUpTo: 1024 * 1024) newSpaceSize: 1024 * 1024 stackSize: 1024 * 1024 codeSize: 1024 * 1024. + newHeap setCheckForLeaks: 15 - 6. "don't check become; or newSpace; soooo many rehashes in bootstrap" - newHeap setCheckForLeaks: 15 - 4. "don't check become; soooo many rehashes in bootstrap" map := Dictionary new: oldHeap memory size // 4. reverseMap := Dictionary new: oldHeap memory size // 4. classToIndex := Dictionary new: 1024. literalMap := IdentityDictionary new. methodClasses := Set new. installedPrototypes := Set new! Item was changed: ----- Method: SpurBootstrap>>selectorForPrototypeMethod: (in category 'method prototypes') ----- selectorForPrototypeMethod: protoMethod | protoSelector | protoSelector := protoMethod selector. + protoSelector := protoSelector last: protoSelector size - ^(protoSelector last: protoSelector size - (protoSelector indexOfSubCollection: 'PROTOTYPE') - 'PROTOTYPE' size + + 1. + (protoSelector beginsWith: 'Dollar') ifTrue: + [protoSelector := (Dictionary newFromPairs: #('DollarEquals:' #=)) + at: protoSelector]. + ^protoSelector asSymbol! - + 1) asSymbol! Item was changed: ----- Method: SpurBootstrap>>writeSnapshotOfTransformedImage (in category 'testing') ----- writeSnapshotOfTransformedImage "The bootstrapped image typically contains a few big free chunks and one huge free chunk. Test snapshot writing and loading by turning the largest non-huge chunks into segment bridges and saving." | last heap sizes counts barriers sim | heap := TransformedImage veryDeepCopy. sim := StackInterpreterSimulator onObjectMemory: heap. heap coInterpreter: sim. sim initializeInterpreter: 0; setImageHeaderFlagsFrom: ImageHeaderFlags; setDisplayForm: (Form extent: ImageScreenSize >> 16 @ (ImageScreenSize bitAnd: 16rFFFF)). heap allOldSpaceEntitiesDo: [:e| last := e]. self assert: (heap isFreeObject: last). sizes := Bag new. heap allObjectsInFreeTree: (heap freeLists at: 0) do: [:f| sizes add: (heap bytesInObject: f)]. counts := sizes sortedCounts. self assert: counts last key = 1. "1 huge chunk" self assert: ((counts at: counts size - 1) key > 2 and: [(counts at: counts size - 1) value > 1024]). barriers := (1 to: (counts at: counts size - 1) key) collect: [:ign| heap allocateOldSpaceChunkOfExactlyBytes: (counts at: counts size - 1) value]. barriers := barriers, {heap allocateOldSpaceChunkOfExactlyBytes: (heap bytesInObject: last)}. heap setEndOfMemory: barriers last. heap allOldSpaceEntitiesDo: [:e| last := e]. self assert: (heap addressAfter: last) = barriers last. heap checkFreeSpace. heap runLeakCheckerForFullGC: true. heap segmentManager initializeFromFreeChunks: (barriers sort collect: [:b| heap objectStartingAt: b]). heap checkFreeSpace. heap runLeakCheckerForFullGC: true. + sim bereaveAndNormalizeContextsAndFlushExternalPrimitives. sim imageName: 'spur.image'. sim writeImageFileIO!

1 0

VM Maker: Cog-eem.113.mcz
by commits＠source.squeak.org 11 Oct '13

11 Oct '13

Eliot Miranda uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog-eem.113.mcz ==================== Summary ==================== Name: Cog-eem.113 Author: eem Time: 11 October 2013, 10:09:35.348 am UUID: 79cf1a1f-f091-4e6d-921f-610983da576e Ancestors: Cog-eem.112 Set the display size in the saved transformed Spur image. =============== Diff against Cog-eem.112 =============== Item was changed: Object subclass: #SpurBootstrap instanceVariableNames: 'oldHeap newHeap oldHeapSize newHeapSize map reverseMap classToIndex oldInterpreter lastClassTablePage literalMap methodClasses installedPrototypes sizeSym rehashSym classMetaclass' + classVariableNames: 'ImageHeaderFlags ImageName ImageScreenSize TransformedImage' - classVariableNames: 'ImageHeaderFlags ImageName TransformedImage' poolDictionaries: 'VMObjectIndices' category: 'Cog-Bootstrapping'! !SpurBootstrap commentStamp: 'eem 9/11/2013 05:45' prior: 0! SpurBootstrap bootstraps an image in SpurMemoryManager format from a Squeak V3 + closures format. e.g. (SpurBootstrap32 new on: '/Users/eliot/Cog/startreader.image') transform; launch Bootstrap issues: - should it implement a deterministic Symbol identityHash? This means set a Symbol's identityHash at instance creation time based on its string hash so that e.g. MethodDIctionary instances have a deterministic order and don't need to be rehashed on load. - should it collapse ContextPart and MethodContext down onto Context (and perhaps eliminate BlockContext)? Instance Variables classToIndex: <Dictionary> lastClassTablePage: <Integer> map: <Dictionary> methodClasses: <Set> newHeap: <SpurMemoryManager> oldHeap: <NewObjectMemory> oldInterpreter: <StackInterpreterSimulator> reverseMap: <Dictionary> symbolMap: <Dictionary> classToIndex - oldClass to new classIndex map lastClassTablePage - oop in newHeap of last classTable page. U<sed in validation to filter-out class table. methodClasses - cache of methodClassAssociations for classes in which modified methods are installed map - oldObject to newObject map newHeap - the output, bootstrapped image oldHeap - the input, image oldInterpreter - the interpreter associated with oldHeap, needed for a hack to grab WeakArray reverseMap - newObject to oldObject map symbolMap - symbol toi symbol oop in oldHeap, used to map prototype methdos to methods in oldHeap! Item was changed: ----- Method: SpurBootstrap>>saveTransformedImage (in category 'development support') ----- saveTransformedImage ImageHeaderFlags := oldInterpreter getImageHeaderFlags. + ImageScreenSize := oldInterpreter savedWindowSize. ImageName := oldInterpreter imageName. newHeap coInterpreter: nil. (newHeap class allInstVarNames select: [:ivn| ivn beginsWith: 'stat']) do: [:ivn| newHeap instVarNamed: ivn put: 0]. TransformedImage := newHeap veryDeepCopy! Item was changed: ----- Method: SpurBootstrap>>writeSnapshotOfTransformedImage (in category 'testing') ----- writeSnapshotOfTransformedImage "The bootstrapped image typically contains a few big free chunks and one huge free chunk. Test snapshot writing and loading by turning the largest non-huge chunks into segment bridges and saving." | last heap sizes counts barriers sim | heap := TransformedImage veryDeepCopy. sim := StackInterpreterSimulator onObjectMemory: heap. heap coInterpreter: sim. sim initializeInterpreter: 0; + setImageHeaderFlagsFrom: ImageHeaderFlags; + setDisplayForm: (Form extent: ImageScreenSize >> 16 @ (ImageScreenSize bitAnd: 16rFFFF)). - setImageHeaderFlagsFrom: ImageHeaderFlags. heap allOldSpaceEntitiesDo: [:e| last := e]. self assert: (heap isFreeObject: last). sizes := Bag new. heap allObjectsInFreeTree: (heap freeLists at: 0) do: [:f| sizes add: (heap bytesInObject: f)]. counts := sizes sortedCounts. self assert: counts last key = 1. "1 huge chunk" self assert: ((counts at: counts size - 1) key > 2 and: [(counts at: counts size - 1) value > 1024]). barriers := (1 to: (counts at: counts size - 1) key) collect: [:ign| heap allocateOldSpaceChunkOfExactlyBytes: (counts at: counts size - 1) value]. barriers := barriers, {heap allocateOldSpaceChunkOfExactlyBytes: (heap bytesInObject: last)}. heap setEndOfMemory: barriers last. heap allOldSpaceEntitiesDo: [:e| last := e]. self assert: (heap addressAfter: last) = barriers last. heap checkFreeSpace. heap runLeakCheckerForFullGC: true. heap segmentManager initializeFromFreeChunks: (barriers sort collect: [:b| heap objectStartingAt: b]). heap checkFreeSpace. heap runLeakCheckerForFullGC: true. sim imageName: 'spur.image'. sim writeImageFileIO!

1 0

VM Maker: VMMaker.oscog-eem.450.mcz
by commits＠source.squeak.org 11 Oct '13

11 Oct '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.450.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.450 Author: eem Time: 11 October 2013, 9:48:56.883 am UUID: 86e607b5-0e72-4bf7-bda3-064b59b40267 Ancestors: VMMaker.oscog-eem.449 Fix swizzling: - search the segments in reverse order for the first segment whose start is less than or equal to the oop. - add an assert set in adjustSegmentSwizzlesBy: and cleared in collapseSegmentsPostSwizzle that checks that swizzling is done only while the swizzle info is valid (numSegments reflects the num of segs in the image, not in the loaded system). - swizzle the freeLists before collapseSegmentsPostSwizzle. =============== Diff against VMMaker.oscog-eem.449 =============== Item was added: + ----- Method: CObjectAccessor>>first (in category 'accessing') ----- + first + ^self at: 0! Item was changed: ----- Method: SpurMemoryManager>>initializeObjectMemory: (in category 'initialization') ----- initializeObjectMemory: bytesToShift "Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks." "Assume: image reader initializes the following variables: memory memoryLimit specialObjectsOop lastHash " <inline: false> | freeListObj | + self halt. segmentManager adjustSegmentSwizzlesBy: bytesToShift. "image may be at a different address; adjust oops for new location" self adjustAllOopsBy: bytesToShift. segmentManager numSegments > 0 "false if Spur image bootstrap" ifTrue: [specialObjectsOop := segmentManager swizzleObj: specialObjectsOop] ifFalse: [self assert: bytesToShift = 0]. - segmentManager collapseSegmentsPostSwizzle. - "heavily used special objects" nilObj := self splObj: NilObject. falseObj := self splObj: FalseObject. trueObj := self splObj: TrueObject. "In Cog we insist that nil, true & false are next to each other (Cogit generates tighter conditional branch code as a result). In addition, Spur places the free lists and class table root page immediately following them." self assert: nilObj = newSpaceLimit. self assert: falseObj = (self objectAfter: nilObj). self assert: trueObj = (self objectAfter: falseObj). freeListObj := self objectAfter: trueObj. self classTableRootObj: (self objectAfter: freeListObj). self initializeFreeSpacePostLoad: freeListObj. + + segmentManager collapseSegmentsPostSwizzle. . self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart" "lowSpaceThreshold := 0. signalLowSpace := false. remapBufferCount := 0. tenuringThreshold := 2000. ""tenure all suriving objects if survivor count is over this threshold"" growHeadroom := 4*1024*1024. ""four megabytes of headroom when growing"" shrinkThreshold := 8*1024*1024. ""eight megabytes of free space before shrinking"" ""garbage collection statistics"" statFullGCs := 0. statFullGCUsecs := 0. statIncrGCs := 0. statIncrGCUsecs := 0. statTenures := 0. statRootTableOverflows := 0. statGrowMemory := 0. statShrinkMemory := 0. forceTenureFlag := 0. gcBiasToGrow := 0. gcBiasToGrowGCLimit := 0. extraRootCount := 0."! Item was changed: ----- Method: SpurMemoryManager>>isValidFreeObject: (in category 'free space') ----- isValidFreeObject: objOop | chunk | + ^(self addressCouldBeObj: objOop) + and: [(self isFreeObject: objOop) - ^(self isFreeObject: objOop) and: [((chunk := (self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop)) = 0 or: [self isFreeObject: chunk]) and: [(self bytesInObject: objOop) / self allocationUnit < self numFreeLists or: [((chunk := (self fetchPointer: self freeChunkParentIndex ofFreeChunk: objOop)) = 0 or: [self isFreeObject: chunk]) and: [((chunk := (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: objOop)) = 0 or: [self isFreeObject: chunk]) and: [(chunk := (self fetchPointer: self freeChunkLargerIndex ofFreeChunk: objOop)) = 0 + or: [self isFreeObject: chunk]]]]]]]! - or: [self isFreeObject: chunk]]]]]]! Item was changed: ----- Method: SpurMemoryManager>>unlinkFreeChunk:atIndex: (in category 'free space') ----- unlinkFreeChunk: chunk atIndex: index + "Unlink and answer a small chunk from one of the fixed size freeLists" <inline: true> self assert: ((self bytesInObject: chunk) = (index * self allocationUnit) + and: [index > 1 "a.k.a. (self bytesInObject: chunk) > self allocationUnit" + and: [(self startOfObject: chunk) = chunk]]). - and: [index > 1 "a.k.a. (self bytesInObject: chunk) > self allocationUnit"]). freeLists at: index put: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk). ^chunk! Item was changed: CogClass subclass: #SpurSegmentManager + instanceVariableNames: 'manager numSegments numSegInfos segments firstSegmentSize canSwizzle' - instanceVariableNames: 'manager numSegments numSegInfos segments firstSegmentSize' classVariableNames: '' poolDictionaries: '' category: 'VMMaker-SpurMemoryManager'! !SpurSegmentManager commentStamp: 'eem 10/6/2013 10:32' prior: 0! Instances of SpurSegmentManager manage oldSpace, which is organized as a sequence of segments. Segments can be obtained from the operating system and returned to the operating system when empty and shrinkage is required. Segments are kept invisible from the SpurMemoryManager by using "bridge" objects, "fake" pinned objects to bridge the gaps between segments. A pinned object header occupies the last 16 bytes of each segment, and the pinned object's size is the distance to the start of the next segment. So when the memory manager enumerates objects it skips over these bridges and memory appears linear. The constraint is that segments obtained from the operating system must be at a higher address than the first segment. The maximum size of large objects, being an overflow slot size, should be big enough to bridge the gaps, because in 32-bits the maximum size is 2^32 slots. In 64-bits the maximum size of large objects is 2^56 slots, or 2^59 bits, which we hope will suffice. When an image is written to a snapshot file the second word of the header of the bridge at the end of each segment is replaced by the size of the following segment, the segments are written to the file, and the second word of each bridge is restored. Hence the length of each segment is derived from the bridge at the end of the preceeding segment. The length of the first segment is stored in the image header as firstSegmentBytes. The start of each segment is also derived from the bridge as a delta from the start of the previous segment. The start of The first segment is stored in the image header as startOfMemory. On load all segments are read into one single segment, eliminating the bridge objects, and computing the swizzle distance for each segment, based on where the segments were in memory when the image file was written, and where the coallesced segment ends up on load. Then the segment is traversed, swizzling pointers by selecting the relevant swizzle for each oop's segment. Instance Variables numSegments: <Integer> segments: <Array of SpurSegmentInfo> manager: <SpurMemoryManager> numSegments - the number of segments segments - the start addresses, lengths and offsets to adjust oops on image load, for each segment manager - the SpurMemoryManager whose oldSpace is managed (simulation only).! 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 start: segInfo start + oldBaseAddr; + swizzle: segInfo swizzle - oldBaseAddr]. + canSwizzle := true! - swizzle: segInfo swizzle - oldBaseAddr"+ firstSegmentShift"]! 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. (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>>initialize (in category 'initialization') ----- initialize + numSegments := numSegInfos := 0. + canSwizzle := false! - numSegments := numSegInfos := 0! Item was changed: ----- Method: SpurSegmentManager>>swizzleObj: (in category 'snapshot') ----- swizzleObj: objOop + self assert: canSwizzle. + numSegments - 1 to: 1 by: -1 do: - 1 to: numSegments - 1 do: [:i| + objOop >= (segments at: i) start ifTrue: + [^objOop + (segments at: i) swizzle]]. + ^objOop + (segments at: 0) swizzle! - objOop < (segments at: i) start ifTrue: - [^objOop + (segments at: i - 1) swizzle]]. - ^objOop + (segments at: numSegments - 1) swizzle!

1 0

[unix] 4.10.2.2614 segfaults on ARM
by Bert Freudenberg 11 Oct '13

11 Oct '13

The same image works fine using the interpreter on x86, and on various other VMs. Here's the drgeo.image, inside a zip renamed to .xo: https://gforge.inria.fr/frs/download.php/30585/DrGeoII-12.04.xo (original report below) Any idea what might be wrong? - Bert - Begin forwarded message: > From: "Daniel Drake [via Dr. Geo Forum]" <ml-node+s996172n4024197h7(a)n3.nabble.com> > Subject: Running on OLPC XO-1.75 (ARM) > Date: 8. Oktober 2013 23:41:32 MESZ > To: bert <bert(a)freudenbergs.de> > > Hi, > > I am trying to run DrGeo on OLPC XO-1.75 using the Sugar activity provided. > > This fails to launch because the Sugar activity includes an x86 Squeak VM. I modified the launcher script to use the system-wide Squeak VM (we have 4.10.2.2614, also used for Scratch and Etoys) but without success. > > Now, I briefly see a window, then it crashes with: > Segmentation fault > -1799995044 UndefinedObject>? > Segmentation fault > > Any ideas or things I can try? I guess the squeak VM we are running there is much newer than the one shipped in the Sugar activity - maybe there is a new drgeo image that I could try against the new VM? > > Thanks > Daniel > >

5 16

VM Maker: VMMaker.oscog-eem.449.mcz
by commits＠source.squeak.org 11 Oct '13

11 Oct '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.449.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.449 Author: eem Time: 10 October 2013, 5:44:25.893 pm UUID: 6e6aa8be-c134-4a8b-9911-0e97fa4055cd Ancestors: VMMaker.oscog-eem.448 Reimplement segmented loading to eliminate the bridges by reading a segment at a time, instead of reading entire heap in one go and freeing bridges after the fact. Refactor image reading into ObjectMemory et al >>readHeapFromImageFile:dataBytes:. Make SpurMemoryManager>>setEndOfMemory: cut back freeOldSpaceStart if required for the bootstrap snapshot. Make printNameOfClass:count: et al cope with a nil classNameIndex for pre-initialization debugging (i.e. of just swizzled images). Bootstrapped image loads but doesn't launch. 6th element in freeLists is invalid. Ho hum... =============== Diff against VMMaker.oscog-eem.448 =============== Item was changed: ----- Method: CoInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') ----- readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory heapSize bytesRead bytesToShift hdrNumStackPages hdrEdenBytes hdrCogCodeSize headerFlags hdrMaxExtSemTabSize firstSegSize | <var: #f type: 'sqImageFile '> <var: #memStart type: 'usqInt'> <var: #desiredHeapSize type: 'usqInt'> <var: #headerStart type: 'squeakFileOffsetType '> <var: #dataSize type: 'size_t '> <var: #imageOffset type: 'squeakFileOffsetType '> metaclassSizeBits := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)" swapBytes := self checkImageVersionFrom: f startingAt: imageOffset. headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position" headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. oldBaseAddr := self getLongFromFile: f swap: swapBytes. objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes). objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used." savedWindowSize := self getLongFromFile: f swap: swapBytes. headerFlags := self getLongFromFile: f swap: swapBytes. self setImageHeaderFlagsFrom: headerFlags. extraVMMemory := self getLongFromFile: f swap: swapBytes. "N.B. not used." hdrNumStackPages := self getShortFromFile: f swap: swapBytes. "4 stack pages is small. Should be able to run with as few as three. 4 should be comfortable but slow. 8 is a reasonable default. Can be changed via vmParameterAt: 43 put: n. Can be set as a preference (Info.plist, VM.ini, command line etc). If desiredNumStackPages is already non-zero then it has been set as a preference. Ignore (but preserve) the header's default." numStackPages := desiredNumStackPages ~= 0 ifTrue: [desiredNumStackPages] ifFalse: [hdrNumStackPages = 0 ifTrue: [self defaultNumStackPages] ifFalse: [hdrNumStackPages]]. desiredNumStackPages := hdrNumStackPages. "This slot holds the size of the native method zone in 1k units. (pad to word boundary)." hdrCogCodeSize := (self getShortFromFile: f swap: swapBytes) * 1024. cogCodeSize := desiredCogCodeSize ~= 0 ifTrue: [desiredCogCodeSize] ifFalse: [hdrCogCodeSize = 0 ifTrue: [self defaultCogCodeSize] ifFalse: [hdrCogCodeSize]]. hdrEdenBytes := self getLongFromFile: f swap: swapBytes. objectMemory edenBytes: (desiredEdenBytes ~= 0 ifTrue: [desiredEdenBytes] ifFalse: [hdrEdenBytes = 0 ifTrue: [objectMemory defaultEdenBytes] ifFalse: [hdrEdenBytes]]). desiredEdenBytes := hdrEdenBytes. hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes. hdrMaxExtSemTabSize ~= 0 ifTrue: [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize]. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. Preserve it to be polite to other VMs." the2ndUnknownShort := self getShortFromFile: f swap: swapBytes. firstSegSize := self nextLongFrom: f swap: swapBytes. objectMemory firstSegmentSize: firstSegSize. "compare memory requirements with availability" minimumMemory := cogCodeSize "no need to include the stackZone; this is alloca'ed" + dataSize + objectMemory newSpaceBytes + self interpreterAllocationReserveBytes. heapSize := cogCodeSize "no need to include the stackZone; this is alloca'ed" + desiredHeapSize "+ edenBytes" "don't include edenBytes; this is part of the heap and so part of desiredHeapSize" + self interpreterAllocationReserveBytes. heapSize < minimumMemory ifTrue: [self insufficientMemorySpecifiedError]. "allocate a contiguous block of memory for the Squeak heap and ancilliary data structures" objectMemory memory: (self allocateMemory: heapSize minimum: minimumMemory imageFile: f headerSize: headerSize) asUnsignedInteger. objectMemory memory = nil ifTrue: [self insufficientMemoryAvailableError]. heapBase := objectMemory memory + cogCodeSize. self assert: objectMemory startOfMemory = heapBase. objectMemory setHeapBase: heapBase memoryLimit: objectMemory memory + heapSize - 24 "decrease memoryLimit a tad for safety (?!!?!!? eem eem 10/9/2013 15:15)" endOfMemory: heapBase + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" + bytesRead := objectMemory readHeapFromImageFile: f dataBytes: dataSize. - bytesRead := self - sq: (self pointerForOop: objectMemory memoryBaseForImageRead) - Image: (self sizeof: #char) - File: dataSize - Read: f. bytesRead ~= dataSize ifTrue: [self unableToReadImageError]. self ensureImageFormatIsUpToDate: swapBytes. "compute difference between old and new memory base addresses" bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" self initializeCodeGenerator. ^dataSize! Item was changed: ----- Method: CogVMSimulator>>openOn:extraMemory: (in category 'initialization') ----- openOn: fileName extraMemory: extraBytes "CogVMSimulator new openOn: 'clone.im' extraMemory: 100000" | f version headerSize count heapSize oldBaseAddr bytesToShift swapBytes hdrNumStackPages hdrEdenBytes hdrCogCodeSize stackZoneSize methodCacheSize headerFlags primTraceLogSize firstSegSize hdrMaxExtSemTabSize | "open image file and read the header" ["begin ensure block..." f := FileStream readOnlyFileNamed: fileName. imageName := f fullName. f binary. version := self nextLongFrom: f. "current version: 16r1968 (=6504) vive la revolucion!!" (self readableFormat: version) ifTrue: [swapBytes := false] ifFalse: [(version := objectMemory byteSwapped: version) = self imageFormatVersion ifTrue: [swapBytes := true] ifFalse: [self error: 'incomaptible image format']]. headerSize := self getLongFromFile: f swap: swapBytes. heapSize := self getLongFromFile: f swap: swapBytes. "length of heap in file" oldBaseAddr := self getLongFromFile: f swap: swapBytes. "object memory base address of image" objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes). objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "Should be loaded from, and saved to the image header" savedWindowSize := self getLongFromFile: f swap: swapBytes. headerFlags := self getLongFromFile: f swap: swapBytes. self setImageHeaderFlagsFrom: headerFlags. extraVMMemory := self getLongFromFile: f swap: swapBytes. hdrNumStackPages := self getShortFromFile: f swap: swapBytes. "4 stack pages is small. Should be able to run with as few as three. 4 should be comfortable but slow. 8 is a reasonable default. Can be changed via vmParameterAt: 43 put: n" numStackPages := desiredNumStackPages ~= 0 ifTrue: [desiredNumStackPages] ifFalse: [hdrNumStackPages = 0 ifTrue: [self defaultNumStackPages] ifFalse: [hdrNumStackPages]]. desiredNumStackPages := hdrNumStackPages. stackZoneSize := self computeStackZoneSize. "This slot holds the size of the native method zone in 1k units. (pad to word boundary)." hdrCogCodeSize := (self getShortFromFile: f swap: swapBytes) * 1024. cogCodeSize := desiredCogCodeSize ~= 0 ifTrue: [desiredCogCodeSize] ifFalse: [hdrCogCodeSize = 0 ifTrue: [self defaultCogCodeSize] ifFalse: [hdrCogCodeSize]]. desiredCogCodeSize := hdrCogCodeSize. self assert: f position = 40. hdrEdenBytes := self getLongFromFile: f swap: swapBytes. objectMemory edenBytes: (desiredEdenBytes ~= 0 ifTrue: [desiredEdenBytes] ifFalse: [hdrEdenBytes = 0 ifTrue: [objectMemory defaultEdenBytes] ifFalse: [hdrEdenBytes]]). desiredEdenBytes := hdrEdenBytes. hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes. hdrMaxExtSemTabSize ~= 0 ifTrue: [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize]. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. Preserve it to be polite to other VMs." the2ndUnknownShort := self getShortFromFile: f swap: swapBytes. self assert: f position = 48. firstSegSize := self getLongFromFile: f swap: swapBytes. objectMemory firstSegmentSize: firstSegSize. "For Open PICs to be able to probe the method cache during simulation the methodCache must be relocated to memory." methodCacheSize := methodCache size * BytesPerWord. primTraceLogSize := primTraceLog size * BytesPerWord. "allocate interpreter memory. This list is in address order, low to high. In the actual VM the stack zone exists on the C stack." heapBase := cogCodeSize + stackZoneSize + methodCacheSize + primTraceLogSize + self rumpCStackSize. objectMemory setHeapBase: heapBase memoryLimit: heapBase + heapSize + objectMemory newSpaceBytes + self interpreterAllocationReserveBytes + extraBytes endOfMemory: heapBase + heapSize. objectMemory initialize. self assert: cogCodeSize \\ 4 = 0. self assert: objectMemory memoryLimit \\ 4 = 0. self assert: self rumpCStackSize \\ 4 = 0. "read in the image in bulk, then swap the bytes if necessary" f position: headerSize. objectMemory memory: ((cogit processor endianness == #little ifTrue: [LittleEndianBitmap] ifFalse: [Bitmap]) new: objectMemory memoryLimit // 4). + count := objectMemory readHeapFromImageFile: f dataBytes: heapSize. + count ~= heapSize ifTrue: [self halt]. - count := f readInto: objectMemory memory - startingAt: objectMemory memoryBaseForImageRead // 4 + 1 - count: heapSize // 4. - count ~= (heapSize // 4) ifTrue: [self halt]. ] ensure: [f close]. self moveMethodCacheToMemoryAt: cogCodeSize + stackZoneSize. self movePrimTraceLogToMemoryAt: cogCodeSize + stackZoneSize + methodCacheSize. self ensureImageFormatIsUpToDate: swapBytes. bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr. "adjust pointers for zero base address" Utilities informUser: 'Relocating object pointers...' during: [self initializeInterpreter: bytesToShift]. self initializeCodeGenerator! Item was added: + ----- Method: NewObjectMemorySimulator>>memoryBaseForImageRead (in category 'image save/restore') ----- + memoryBaseForImageRead + "Answer the address to read the image into." + ^0! Item was added: + ----- Method: ObjectMemory>>readHeapFromImageFile:dataBytes: (in category 'image save/restore') ----- + readHeapFromImageFile: f dataBytes: numBytes + "Read numBytes of image data from f into memory at memoryBaseForImageRead. + Answer the number of bytes written." + ^self cCode: + [self + sq: (self pointerForOop: self memoryBaseForImageRead) + Image: (self sizeof: #char) + File: numBytes + Read: f] + inSmalltalk: + [(f readInto: memory + startingAt: self memoryBaseForImageRead // 4 + 1 + count: numBytes // 4) + * 4]! Item was changed: + ----- Method: SpurMemoryManager>>adjustAllOopsBy: (in category 'snapshot') ----- - ----- Method: SpurMemoryManager>>adjustAllOopsBy: (in category 'initialization') ----- adjustAllOopsBy: bytesToShift "Adjust all oop references by the given number of bytes. This is done just after reading in an image when the new base address of the object heap is different from the base address in the image, or when loading multiple segments that have been coallesced." | obj | (bytesToShift ~= 0 or: [segmentManager numSegments > 1]) ifTrue: [self assert: self newSpaceIsEmpty. obj := self objectStartingAt: newSpaceLimit. [self oop: obj isLessThan: freeOldSpaceStart] whileTrue: [(self isFreeObject: obj) ifTrue: [self swizzleFieldsOfFreeChunk: obj] ifFalse: [self swizzleFieldsOfObject: obj]. obj := self objectAfter: obj]]! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes: (in category 'free space') ----- allocateOldSpaceChunkOfExactlyBytes: chunkBytes "Answer a chunk of oldSpace from the free lists, if one of this size is available, otherwise answer nil. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." | initialIndex node nodeBytes parent child smaller larger | "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" initialIndex := chunkBytes / self allocationUnit. initialIndex < self numFreeLists ifTrue: [(1 << initialIndex <= freeListsMask and: [(node := freeLists at: initialIndex) ~= 0]) ifTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self unlinkFreeChunk: node atIndex: initialIndex]. ^nil]. "Large chunk. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the first chunk of the same size as chunkBytes, or 0 if none." node := 0. child := freeLists at: 0. [child ~= 0] whileTrue: [| childBytes | self assert: (self isValidFreeObject: child). childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. node ~= 0 ifTrue: [self assert: (self isValidFreeObject: node). self storePointer: self freeChunkNextIndex ofFreeChunk: child withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node). totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: node]. node := child. nodeBytes := childBytes. child := 0] "break out of loop to remove interior node" ifFalse: [childBytes < chunkBytes ifTrue: "walk down the tree" [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child] ifFalse: [nodeBytes := childBytes. child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]]. "if no chunk, there was no exact fit" node = 0 ifTrue: [^nil]. "self printFreeChunk: parent" self assert: nodeBytes = chunkBytes. self assert: (self bytesInObject: node) = chunkBytes. "can't be a list; would have removed and returned it above." self assert: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) = 0. "no list; remove an interior node; reorder tree simply. two cases (which have mirrors, for four total): case 1. interior node has one child, P = parent, N = node, S = subtree (mirrored for large vs small) ___ ___ | P | | P | _/_ _/_ | N | => | S | _/_ | S | case 2: interior node has two children, , P = parent, N = node, L = smaller, left subtree, R = larger, right subtree. add the left subtree to the bottom left of the right subtree (mirrored for large vs small) ___ ___ | P | | P | _/_ _/_ | N | => | R | _/_ _\_ _/_ | L | | R | | L |" smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node. larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: node. parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: node. parent = 0 ifTrue: "no parent; stitch the subnodes back into the root" [smaller = 0 ifTrue: [self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: 0. freeLists at: 0 put: larger] ifFalse: [self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: 0. freeLists at: 0 put: smaller. larger ~= 0 ifTrue: [self addFreeSubTree: larger]]] ifFalse: "parent; stitch back into appropriate side of parent." [smaller = 0 ifTrue: [self storePointer: (node = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent) ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: parent withValue: larger. self storePointer: self freeChunkParentIndex ofObject: larger withValue: parent] ifFalse: [self storePointer: (node = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent) ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: parent withValue: smaller. self storePointer: self freeChunkParentIndex ofObject: smaller withValue: parent. larger ~= 0 ifTrue: [self addFreeSubTree: larger]]]. + totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: node! Item was added: + ----- Method: SpurMemoryManager>>bridgeSize (in category 'segments') ----- + bridgeSize + ^2 * self baseHeaderSize! Item was added: + ----- Method: SpurMemoryManager>>initializeFreeSpacePostLoad: (in category 'snapshot') ----- + initializeFreeSpacePostLoad: freeListObj + "Reinitialize the free list info. The freeLists object needs to be swizzled + because its neither a free, nor a pointer object. Free objects have already + been swizzled in adjustAllOopsBy:" + + self assert: (self numSlotsOf: freeListObj) = self numFreeLists. + self assert: (self formatOf: freeListObj) = (self wordSize = 4 + ifTrue: [self firstLongFormat] + ifFalse: [self sixtyFourBitIndexableFormat]). + + segmentManager numSegments = 0 ifTrue: "true in Spur image bootstrap" + [^self]. + self halt. + freeLists := self firstIndexableField: freeListObj. + 0 to: self numFreeLists - 1 do: + [:i| + (freeLists at: i) ~= 0 ifTrue: + [freeListsMask := freeListsMask bitOr: (1 << i). + segmentManager numSegments > 0 ifTrue: + [freeLists at: i put: (segmentManager swizzleObj: (freeLists at: i))]]]. + totalFreeOldSpace := self totalFreeListBytes! Item was changed: ----- Method: SpurMemoryManager>>initializeObjectMemory: (in category 'initialization') ----- initializeObjectMemory: bytesToShift "Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks." "Assume: image reader initializes the following variables: memory memoryLimit specialObjectsOop lastHash " <inline: false> | freeListObj | + segmentManager adjustSegmentSwizzlesBy: bytesToShift. - segmentManager parseSegmentsInNewlyLoadedImage: bytesToShift. "image may be at a different address; adjust oops for new location" self adjustAllOopsBy: bytesToShift. segmentManager numSegments > 0 "false if Spur image bootstrap" ifTrue: [specialObjectsOop := segmentManager swizzleObj: specialObjectsOop] ifFalse: [self assert: bytesToShift = 0]. + segmentManager collapseSegmentsPostSwizzle. + "heavily used special objects" nilObj := self splObj: NilObject. falseObj := self splObj: FalseObject. trueObj := self splObj: TrueObject. "In Cog we insist that nil, true & false are next to each other (Cogit generates tighter conditional branch code as a result). In addition, Spur places the free lists and class table root page immediately following them." self assert: nilObj = newSpaceLimit. self assert: falseObj = (self objectAfter: nilObj). self assert: trueObj = (self objectAfter: falseObj). freeListObj := self objectAfter: trueObj. - self assert: (self numSlotsOf: freeListObj) = self numFreeLists. - self assert: (self formatOf: freeListObj) = (self wordSize = 4 - ifTrue: [self firstLongFormat] - ifFalse: [self sixtyFourBitIndexableFormat]). - freeLists := self firstIndexableField: freeListObj. - 0 to: self numFreeLists - 1 do: - [:i| - (freeLists at: i) ~= 0 ifTrue: - [freeLists at: i put: (segmentManager swizzleObj: (freeLists at: i))]]. self classTableRootObj: (self objectAfter: freeListObj). + self initializeFreeSpacePostLoad: freeListObj. . - segmentManager collapseSegmentsPostSwizzle. self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart" "lowSpaceThreshold := 0. signalLowSpace := false. remapBufferCount := 0. tenuringThreshold := 2000. ""tenure all suriving objects if survivor count is over this threshold"" growHeadroom := 4*1024*1024. ""four megabytes of headroom when growing"" shrinkThreshold := 8*1024*1024. ""eight megabytes of free space before shrinking"" ""garbage collection statistics"" statFullGCs := 0. statFullGCUsecs := 0. statIncrGCs := 0. statIncrGCUsecs := 0. statTenures := 0. statRootTableOverflows := 0. statGrowMemory := 0. statShrinkMemory := 0. forceTenureFlag := 0. gcBiasToGrow := 0. gcBiasToGrowGCLimit := 0. extraRootCount := 0."! Item was added: + ----- Method: SpurMemoryManager>>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." + <doNotGenerate> + ^segmentManager readHeapFromImageFile: f dataBytes: numBytes! Item was changed: ----- Method: SpurMemoryManager>>setEndOfMemory: (in category 'snapshot') ----- setEndOfMemory: newEndOfMemory + "Set by the segment manager after swizzling the image, + and by the SpurBootstrap on writing out the transformed image." + endOfMemory := newEndOfMemory. + freeOldSpaceStart > newEndOfMemory ifTrue: + [freeOldSpaceStart := newEndOfMemory]! - "Set by the segment manager after swizzling the image." - endOfMemory := newEndOfMemory! Item was changed: + ----- Method: SpurMemoryManager>>swizzleFieldsOfFreeChunk: (in category 'snapshot') ----- - ----- Method: SpurMemoryManager>>swizzleFieldsOfFreeChunk: (in category 'initialization') ----- swizzleFieldsOfFreeChunk: chunk <inline: true> 0 to: ((self bytesInObject: chunk) / self allocationUnit > self numFreeLists ifTrue: [self freeChunkLargerIndex] ifFalse: [self freeChunkNextIndex]) do: [:index| | field | field := self fetchPointer: index ofFreeChunk: chunk. field ~= 0 ifTrue: [self storePointer: index ofFreeChunk: chunk withValue: (segmentManager swizzleObj: field)]]! Item was changed: + ----- Method: SpurMemoryManager>>swizzleFieldsOfObject: (in category 'snapshot') ----- - ----- Method: SpurMemoryManager>>swizzleFieldsOfObject: (in category 'initialization') ----- swizzleFieldsOfObject: oop | fieldAddr fieldOop | <inline: true> fieldAddr := oop + (self lastPointerOf: oop). [self oop: fieldAddr isGreaterThanOrEqualTo: oop + self baseHeaderSize] whileTrue: [fieldOop := self longAt: fieldAddr. (self isNonImmediate: fieldOop) ifTrue: [self longAt: fieldAddr put: (segmentManager swizzleObj: fieldOop)]. fieldAddr := fieldAddr - BytesPerOop]! Item was changed: ----- Method: SpurMemoryManager>>totalFreeListBytes (in category 'free space') ----- totalFreeListBytes | freeBytes bytesInObject obj | freeBytes := 0. 1 to: self numFreeLists - 1 do: [:i| bytesInObject := i * self allocationUnit. obj := freeLists at: i. [obj ~= 0] whileTrue: [freeBytes := freeBytes + bytesInObject. - self assert: bytesInObject = (self bytesInObject: obj). self assert: (self isValidFreeObject: obj). + self assert: bytesInObject = (self bytesInObject: obj). obj := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj]]. ^freeBytes + (self bytesInFreeTree: (freeLists at: 0))! Item was changed: CogClass subclass: #SpurSegmentManager + instanceVariableNames: 'manager numSegments numSegInfos segments firstSegmentSize' - instanceVariableNames: 'manager numSegments segments firstSegmentSize numSegmentsAllocated' classVariableNames: '' poolDictionaries: '' category: 'VMMaker-SpurMemoryManager'! !SpurSegmentManager commentStamp: 'eem 10/6/2013 10:32' prior: 0! Instances of SpurSegmentManager manage oldSpace, which is organized as a sequence of segments. Segments can be obtained from the operating system and returned to the operating system when empty and shrinkage is required. Segments are kept invisible from the SpurMemoryManager by using "bridge" objects, "fake" pinned objects to bridge the gaps between segments. A pinned object header occupies the last 16 bytes of each segment, and the pinned object's size is the distance to the start of the next segment. So when the memory manager enumerates objects it skips over these bridges and memory appears linear. The constraint is that segments obtained from the operating system must be at a higher address than the first segment. The maximum size of large objects, being an overflow slot size, should be big enough to bridge the gaps, because in 32-bits the maximum size is 2^32 slots. In 64-bits the maximum size of large objects is 2^56 slots, or 2^59 bits, which we hope will suffice. When an image is written to a snapshot file the second word of the header of the bridge at the end of each segment is replaced by the size of the following segment, the segments are written to the file, and the second word of each bridge is restored. Hence the length of each segment is derived from the bridge at the end of the preceeding segment. The length of the first segment is stored in the image header as firstSegmentBytes. The start of each segment is also derived from the bridge as a delta from the start of the previous segment. The start of The first segment is stored in the image header as startOfMemory. On load all segments are read into one single segment, eliminating the bridge objects, and computing the swizzle distance for each segment, based on where the segments were in memory when the image file was written, and where the coallesced segment ends up on load. Then the segment is traversed, swizzling pointers by selecting the relevant swizzle for each oop's segment. Instance Variables numSegments: <Integer> segments: <Array of SpurSegmentInfo> manager: <SpurMemoryManager> numSegments - the number of segments segments - the start addresses, lengths and offsets to adjust oops on image load, for each segment manager - the SpurMemoryManager whose oldSpace is managed (simulation only).! Item was added: + ----- 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 + start: segInfo start + oldBaseAddr; + swizzle: segInfo swizzle - oldBaseAddr"+ firstSegmentShift"]! Item was added: + ----- Method: SpurSegmentManager>>allocateOrExtendSegmentInfos (in category 'private') ----- + allocateOrExtendSegmentInfos + "Increase the number of allocated segInfos by 16." + | newNumSegs | + numSegInfos = 0 ifTrue: + [numSegInfos := 16. + segments := self + cCode: [self c: numSegInfos alloc: (self sizeof: SpurSegmentInfo)] + inSmalltalk: [CArrayAccessor on: ((1 to: numSegInfos) collect: [:i| SpurSegmentInfo new])]. + ^self]. + newNumSegs := numSegInfos + 16. + segments := self + cCode: [self re: newNumSegs * (self sizeof: SpurSegmentInfo) alloc: segments] + inSmalltalk: [CArrayAccessor on: segments object, + ((numSegInfos to: newNumSegs) collect: [:i| SpurSegmentInfo new])]. + self cCode: + [segments = 0 ifTrue: + [self error: 'out of memory; cannot allocate more segments']. + self + me: segments + numSegInfos + ms: 0 + et: newNumSegs - numSegInfos * (self sizeof: SpurSegmentInfo)]. + numSegInfos := newNumSegs! 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." - the segments, and free the old bridges." | bridge | firstSegmentSize ifNil: "true when used by SpurBootstrap to transform an image" [^self]. - numSegmentsAllocated := numSegments. - numSegments := 0. - "segment sizes include the two-header-word bridge at the end of each segment." - bridge := firstSegmentSize + manager newSpaceLimit - manager baseHeaderSize. - 1 to: numSegmentsAllocated - 1 do: - [:i| - manager - freeChunkWithBytes: 2 * manager baseHeaderSize - at: bridge - manager baseHeaderSize. - bridge := bridge + (segments at: i) segSize]. - "now bridge is pointing to last bridge in loaded image. free the bridge, add a - bridge at the end of memory, and cut back end of memory to before the bridge." - manager - freeChunkWithBytes: 2 * manager baseHeaderSize - at: bridge - manager baseHeaderSize. - "now update the segment to reflect the coallesced segments" numSegments := 1. (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. - bridge := manager endOfMemory - (2 * manager baseHeaderSize). manager + initSegmentBridgeWithBytes: manager bridgeSize at: bridge; - initSegmentBridgeWithBytes: 2 * manager baseHeaderSize at: bridge; setEndOfMemory: bridge! Item was added: + ----- Method: SpurSegmentManager>>initialize (in category 'initialization') ----- + initialize + numSegments := numSegInfos := 0! Item was changed: ----- Method: SpurSegmentManager>>initializeFromFreeChunks: (in category 'simulation only') ----- initializeFromFreeChunks: freeChunks "For testing, create a set of segments using the freeChunks as bridges." numSegments := freeChunks size. freeChunks do: [:f| manager initSegmentBridgeWithBytes: (manager bytesInObject: f) at: (manager startOfObject: f). self assert: (manager isSegmentBridge: f)]. segments := (1 to: numSegments) collect: [:i| | bridge start size | bridge := freeChunks at: i. start := i = 1 ifTrue: [manager newSpaceLimit] ifFalse: [manager addressAfter: (freeChunks at: i - 1)]. size := bridge + manager baseHeaderSize - start. SpurSegmentInfo new start: start; segSize: size; yourself]. segments := CArrayAccessor on: segments. + freeChunks allButLast do: - freeChunks do: [:bridge| self assert: (manager isValidSegmentBridge: bridge)]! Item was changed: ----- Method: SpurSegmentManager>>manager: (in category 'initialization') ----- manager: aSpurMemoryManager + manager := aSpurMemoryManager! - manager := aSpurMemoryManager. - numSegments ifNil: - [numSegments := 0]! Item was removed: - ----- Method: SpurSegmentManager>>parseSegmentsInNewlyLoadedImage: (in category 'snapshot') ----- - parseSegmentsInNewlyLoadedImage: firstSegmentShift - "Skip through the bridge objects, counting the number of segments. - Then allocate the segment info and scan again, computing the swizzle - ammounts for each segment." - | bridge nextSegmentSize oldBase newBase segInfo bridgeSpan | - <var: 'segInfo' type: 'SpurSegmentInfo *'> - firstSegmentSize ifNil: "true when used by SpurBootstrap to transform an image" - [^self]. - - numSegments := 0. - "segment sizes include the two-header-word bridge at the end of each segment." - bridge := firstSegmentSize + manager newSpaceLimit - manager baseHeaderSize. - [numSegments := numSegments + 1. - nextSegmentSize := manager longLongAt: bridge. - nextSegmentSize ~= 0] whileTrue: - [bridge := bridge + nextSegmentSize]. - segments := self - cCode: [self c: numSegments alloc: (self sizeof: SpurSegmentInfo)] - inSmalltalk: [CArrayAccessor on: ((1 to: numSegments) collect: [:i| SpurSegmentInfo new])]. - - numSegments := 0. - oldBase := manager newSpaceLimit - firstSegmentShift. - newBase := manager newSpaceLimit. - nextSegmentSize := firstSegmentSize. - bridge := firstSegmentSize + manager newSpaceLimit - manager baseHeaderSize. - [segInfo := self addressOf: (segments at: numSegments). - segInfo - start: oldBase; - segSize: nextSegmentSize; - swizzle: newBase - oldBase. - numSegments := numSegments + 1. - bridgeSpan := manager bytesPerSlot * (manager rawOverflowSlotsOf: bridge). - oldBase := oldBase + nextSegmentSize + bridgeSpan. - newBase := newBase + nextSegmentSize. - nextSegmentSize := manager longLongAt: bridge. - nextSegmentSize ~= 0] whileTrue: - [bridge := bridge + nextSegmentSize]. - "newBase should point just past the last bridge." - self assert: (manager longLongAt: newBase - manager baseHeaderSize) = 0. - "set freeOldSpaceStart now for adjustAllOopsBy:" - manager setFreeOldSpaceStart: newBase! Item was added: + ----- Method: SpurSegmentManager>>readHeapFrom:at:dataBytes: (in category 'private') ----- + readHeapFrom: f at: location dataBytes: numBytes + "Read numBytes from f into mmory at location. Answer the number of bytes read." + ^self cCode: + [self + sq: (self pointerForOop: location) + Image: (self sizeof: #char) + File: numBytes + Read: f] + inSmalltalk: + [(f readInto: manager memory + startingAt: location // 4 + 1 + count: numBytes // 4) + * 4]! Item was added: + ----- 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 + 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>>writeSegment:nextSegmentSize:toFile: (in category 'snapshot') ----- writeSegment: aSpurSegmentInfo nextSegmentSize: nextSegSize toFile: aBinaryStream <var: 'aSpurSegmentInfo' type: 'SpurSegmentInfo *'> <var: 'aBinaryStream' type: #'FILE *'> | bridge savedHeader nWritten | <var: 'savedHeader' type: #usqLong> bridge := aSpurSegmentInfo start + aSpurSegmentInfo segSize - manager baseHeaderSize. + "last seg may be beyond endOfMemory/freeOldSpaceStart" + self assert: ((manager isValidSegmentBridge: bridge) or: [nextSegSize = 0]). - self assert: (manager isValidSegmentBridge: bridge). savedHeader := manager longLongAt: bridge. manager longLongAt: bridge put: nextSegSize. nWritten := self cCode: [self sq: aSpurSegmentInfo start Image: 1 File: aSpurSegmentInfo segSize Write: aBinaryStream] inSmalltalk: [aBinaryStream next: aSpurSegmentInfo segSize / 4 putAll: manager memory startingAt: aSpurSegmentInfo start / 4 + 1. aSpurSegmentInfo segSize]. manager longLongAt: bridge put: savedHeader. ^nWritten! Item was changed: ----- Method: StackInterpreter>>printNameOfClass:count: (in category 'debug printing') ----- printNameOfClass: classOop count: cnt "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object." <inline: false> + classNameIndex ifNil: + [self print: '??nil cnidx??'. + ^self]. (classOop isNil or: [classOop = 0 or: [cnt <= 0]]) ifTrue: [^self print: 'bad class']. ((objectMemory sizeBitsOf: classOop) = metaclassSizeBits and: [metaclassSizeBits > (thisClassIndex * BytesPerOop)]) "(Metaclass instSize * 4)" ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1. self print: ' class'] ifFalse: [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]! Item was changed: ----- Method: StackInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') ----- readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr hdrNumStackPages minimumMemory heapBase bytesRead bytesToShift heapSize hdrEdenBytes headerFlags hdrMaxExtSemTabSize firstSegSize | <var: #f type: 'sqImageFile '> <var: #heapBase type: 'usqInt'> <var: #desiredHeapSize type: 'usqInt'> <var: #headerStart type: 'squeakFileOffsetType '> <var: #dataSize type: 'size_t '> <var: #imageOffset type: 'squeakFileOffsetType '> metaclassSizeBits := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)" swapBytes := self checkImageVersionFrom: f startingAt: imageOffset. headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position" headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. oldBaseAddr := self getLongFromFile: f swap: swapBytes. objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes). objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used." savedWindowSize := self getLongFromFile: f swap: swapBytes. headerFlags := self getLongFromFile: f swap: swapBytes. self setImageHeaderFlagsFrom: headerFlags. extraVMMemory := self getLongFromFile: f swap: swapBytes. hdrNumStackPages := self getShortFromFile: f swap: swapBytes. "4 stack pages is small. Should be able to run with as few as three. 4 should be comfortable but slow. 8 is a reasonable default. Can be changed via vmParameterAt: 43 put: n. Can be set as a preference (Info.plist, VM.ini, command line etc). If desiredNumStackPages is already non-zero then it has been set as a preference. Ignore (but preserve) the header's default." numStackPages := desiredNumStackPages ~= 0 ifTrue: [desiredNumStackPages] ifFalse: [hdrNumStackPages = 0 ifTrue: [self defaultNumStackPages] ifFalse: [hdrNumStackPages]]. desiredNumStackPages := hdrNumStackPages. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. It is used for the cog code size in Cog. Preserve it to be polite to other VMs." theUnknownShort := self getShortFromFile: f swap: swapBytes. hdrEdenBytes := self getLongFromFile: f swap: swapBytes. objectMemory edenBytes: (desiredEdenBytes ~= 0 ifTrue: [desiredEdenBytes] ifFalse: [hdrEdenBytes = 0 ifTrue: [objectMemory defaultEdenBytes] ifFalse: [hdrEdenBytes]]). desiredEdenBytes := hdrEdenBytes. hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes. hdrMaxExtSemTabSize ~= 0 ifTrue: [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize]. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. Preserve it to be polite to other VMs." the2ndUnknownShort := self getShortFromFile: f swap: swapBytes. firstSegSize := self nextLongFrom: f swap: swapBytes. objectMemory firstSegmentSize: firstSegSize. "decrease Squeak object heap to leave extra memory for the VM" heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'. "compare memory requirements with availability". minimumMemory := dataSize + objectMemory newSpaceBytes + self interpreterAllocationReserveBytes. heapSize < minimumMemory ifTrue: [self insufficientMemorySpecifiedError]. "allocate a contiguous block of memory for the Squeak heap" objectMemory memory: (self allocateMemory: heapSize minimum: minimumMemory imageFile: f headerSize: headerSize) asUnsignedInteger. objectMemory memory = nil ifTrue: [self insufficientMemoryAvailableError]. heapBase := objectMemory startOfMemory. objectMemory setHeapBase: heapBase memoryLimit: (heapBase + heapSize) - 24 "decrease memoryLimit a tad for safety" endOfMemory: heapBase + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" + bytesRead := objectMemory readHeapFromImageFile: f dataBytes: dataSize. - bytesRead := self - sq: (self pointerForOop: objectMemory memoryBaseForImageRead) - Image: (self sizeof: #char) - File: dataSize - Read: f. bytesRead ~= dataSize ifTrue: [self unableToReadImageError]. self ensureImageFormatIsUpToDate: swapBytes. "compute difference between old and new memory base addresses" bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" ^dataSize! Item was changed: ----- Method: StackInterpreterSimulator>>nameOfClass: (in category 'debug support') ----- nameOfClass: classOop + classNameIndex ifNil: [^'??nil cnidx??']. (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [^(self nameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)) , ' class']. ^self stringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: StackInterpreterSimulator>>openOn:extraMemory: (in category 'initialization') ----- openOn: fileName extraMemory: extraBytes "StackInterpreterSimulator new openOn: 'clone.im' extraMemory: 100000" | f version headerSize dataSize count oldBaseAddr bytesToShift swapBytes hdrNumStackPages hdrEdenBytes headerFlags heapBase firstSegSize hdrMaxExtSemTabSize | "open image file and read the header" ["begin ensure block..." f := FileStream readOnlyFileNamed: fileName. imageName := f fullName. f binary. version := self nextLongFrom: f. "current version: 16r1968 (=6504) vive la revolucion!!" (self readableFormat: version) ifTrue: [swapBytes := false] ifFalse: [(version := objectMemory byteSwapped: version) = self imageFormatVersion ifTrue: [swapBytes := true] ifFalse: [self error: 'incomaptible image format']]. headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. "length of heap in file" oldBaseAddr := self getLongFromFile: f swap: swapBytes. "object memory base address of image" objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes). objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "Should be loaded from, and saved to the image header" savedWindowSize := self getLongFromFile: f swap: swapBytes. headerFlags := self getLongFromFile: f swap: swapBytes. self setImageHeaderFlagsFrom: headerFlags. extraVMMemory := self getLongFromFile: f swap: swapBytes. hdrNumStackPages := self getShortFromFile: f swap: swapBytes. "4 stack pages is small. Should be able to run with as few as three. 4 should be comfortable but slow. 8 is a reasonable default. Can be changed via vmParameterAt: 43 put: n" numStackPages := desiredNumStackPages ~= 0 ifTrue: [desiredNumStackPages] ifFalse: [hdrNumStackPages = 0 ifTrue: [self defaultNumStackPages] ifFalse: [hdrNumStackPages]]. desiredNumStackPages := hdrNumStackPages. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. It is used for the cog code size in Cog. Preserve it to be polite to other VMs." theUnknownShort := self getShortFromFile: f swap: swapBytes. self assert: f position = 40. hdrEdenBytes := self getLongFromFile: f swap: swapBytes. objectMemory edenBytes: (hdrEdenBytes = 0 ifTrue: [objectMemory defaultEdenBytes] ifFalse: [hdrEdenBytes]). desiredEdenBytes := hdrEdenBytes. hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes. hdrMaxExtSemTabSize ~= 0 ifTrue: [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize]. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. Preserve it to be polite to other VMs." the2ndUnknownShort := self getShortFromFile: f swap: swapBytes. self assert: f position = 48. firstSegSize := self getLongFromFile: f swap: swapBytes. objectMemory firstSegmentSize: firstSegSize. "allocate interpreter memory" heapBase := objectMemory startOfMemory. objectMemory setHeapBase: heapBase memoryLimit: heapBase + dataSize + extraBytes + objectMemory newSpaceBytes + self interpreterAllocationReserveBytes endOfMemory: heapBase + dataSize. objectMemory memory: (Bitmap new: objectMemory memoryLimit // 4). "read in the image in bulk, then swap the bytes if necessary" f position: headerSize. + count := objectMemory readHeapFromImageFile: f dataBytes: dataSize. + count ~= dataSize ifTrue: [self halt]. - count := f readInto: objectMemory memory - startingAt: objectMemory memoryBaseForImageRead // 4 + 1 - count: dataSize // 4. - count ~= (dataSize // 4) ifTrue: [self halt]. ] ensure: [f close]. self ensureImageFormatIsUpToDate: swapBytes. bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr. "adjust pointers for zero base address" Utilities informUser: 'Relocating object pointers...' during: [self initializeInterpreter: bytesToShift]. !

1 0

← Newer
1
...
4
5
6
7
8
9
10
...
15
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev October 2013