Vm-dev June 2023

vm-dev@lists.squeakfoundation.org

3 participants
24 discussions

VM Maker: VMMaker.oscog.seperateMarking-WoC.3330.mcz
by commits＠source.squeak.org 12 Jun '23

12 Jun '23

Tom Braun uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog.seperateMarking-WoC.3330.mcz ==================== Summary ==================== Name: VMMaker.oscog.seperateMarking-WoC.3330 Author: WoC Time: 12 June 2023, 11:45:56.975399 am UUID: 6bdce5bc-136b-4541-a100-dd0364c4b0b7 Ancestors: VMMaker.oscog.seperateMarking-WoC.3329 activate TempVectReadBarrier because of (at least for me) missing method (followReceiverAndTemporaryForwardingPointersInStackZone) =============== Diff against VMMaker.oscog.seperateMarking-WoC.3328 =============== Item was changed: ----- Method: SpurMemoryManager>>attemptToShrink (in category 'growing/shrinking memory') ----- attemptToShrink "Attempt to shrink memory after successfully reclaiming lots of memory. If there's enough memory to shrink then be sure to attempt to shrink by at least growHeadroom because segments are typically of that size." + | start | + start := coInterpreter ioUTCMicrosecondsNow. (totalFreeOldSpace > shrinkThreshold and: [totalFreeOldSpace > growHeadroom and: [segmentManager shrinkObjectMemory: (totalFreeOldSpace - growHeadroom max: growHeadroom)]]) ifTrue: + [coInterpreter cr; print: 'shrink time: '; printNum: coInterpreter ioUTCMicrosecondsNow - start; tab; flush. + statShrinkMemory := statShrinkMemory + 1]! - [statShrinkMemory := statShrinkMemory + 1]! Item was changed: ----- Method: SpurSegmentManager>>addSegmentOfSize: (in category 'growing/shrinking memory') ----- addSegmentOfSize: ammount <returnTypeC: #'SpurSegmentInfo *'> <inline: false> | allocatedSize | <var: #newSeg type: #'SpurSegmentInfo *'> <var: #segAddress type: #'void *'> <var: #allocatedSize type: #'usqInt'> self cCode: [] inSmalltalk: [segments ifNil: [^nil]]. "bootstrap" (manager "sent to the manager so that the simulator can increase memory to simulate a new segment" sqAllocateMemorySegmentOfSize: ammount Above: (self firstGapOfSizeAtLeast: ammount) AllocatedSizeInto: (self cCode: [self addressOf: allocatedSize] inSmalltalk: [[:sz| allocatedSize := sz]])) ifNotNil: [:segAddress| | newSegIndex newSeg | newSegIndex := self insertSegmentFor: segAddress asUnsignedIntegerPtr. "Simulation insertion code duplicates entries if newSegIndex ~= numSegments - 1" self cCode: '' inSmalltalk: [segments at: newSegIndex put: SpurSegmentInfo new]. newSeg := self addressOf: (segments at: newSegIndex). newSeg segStart: segAddress asUnsignedIntegerPtr; segSize: allocatedSize; swizzle: 0. "Required in the C version only" self assert: self segmentOverlap not. "self printSegmentAddresses." self bridgeFrom: (self addressOf: (segments at: newSegIndex - 1)) to: newSeg. self bridgeFrom: newSeg to: (newSegIndex = (numSegments - 1) ifFalse: [self addressOf: (segments at: newSegIndex + 1)]). totalHeapSizeIncludingBridges := totalHeapSizeIncludingBridges + allocatedSize. + manager coInterpreter cr; print: '-> '; printNum: totalHeapSizeIncludingBridges ;tab; flush. "test isInMemory:" 0 to: numSegments - 1 do: [:i| self assert: (self isInSegments: (segments at: i) segStart). self assert: (self isInSegments: (segments at: i) segLimit - manager wordSize). self assert: ((self isInSegments: (segments at: i) segLimit) not or: [i < (numSegments - 1) and: [(segments at: i) segLimit = (segments at: i + 1) segStart]]). self assert: ((self isInSegments: (segments at: i) segStart - manager wordSize) not or: [i > 0 and: [(segments at: i - 1) segLimit = (segments at: i) segStart]])]. ^newSeg]. ^nil! Item was changed: ----- Method: SpurSegmentManager>>removeSegment: (in category 'growing/shrinking memory') ----- removeSegment: emptySeg <var: #emptySeg type: #'SpurSegmentInfo *'> | i | i := self indexOfSegment: emptySeg. self assert: i > 0. totalHeapSizeIncludingBridges := totalHeapSizeIncludingBridges - emptySeg segSize. + manager coInterpreter cr; print: '-> '; printNum: totalHeapSizeIncludingBridges ;tab; flush. manager sqDeallocateMemorySegmentAt: emptySeg segStart asVoidPointer OfSize: emptySeg segSize. manager coInterpreter cr; print: 'remove segment '; tab; flush. i to: numSegments - 2 do: [:j| manager gc canReactToShiftSegment: (self addressOf: (segments at: j + 1)) to: j. segments at: j put: (segments at: j + 1)]. self cCode: [] inSmalltalk: [segments at: numSegments - 1 put: SpurSegmentInfo new]. numSegments := numSegments - 1. self bridgeFrom: (self addressOf: (segments at: i - 1)) to: (i <= (numSegments - 1) ifTrue: [self addressOf: (segments at: i)]). manager setLastSegment: (self addressOf: (segments at: numSegments - 1))! Item was changed: ----- Method: StackInterpreter class>>initializePrimitiveTable (in category 'initialization') ----- (excessive size, no diff calculated) Item was changed: ----- Method: StackInterpreter>>whiteOrBogusGreyObjectsOnStackPage: (in category 'debug support') ----- whiteOrBogusGreyObjectsOnStackPage: thePage "Answer if the page refers directly to any white objects." <var: #thePage type: #'StackPage *'> | theSP theFP frameRcvrOffset callerFP oop | theSP := thePage headSP. theFP := thePage headFP. "Skip the instruction pointer on top of stack of inactive pages." thePage = stackPage ifFalse: [theSP := theSP + objectMemory wordSize]. [frameRcvrOffset := self frameReceiverLocation: theFP. [theSP <= frameRcvrOffset] whileTrue: [oop := stackPages longAt: theSP. ((objectMemory isNonImmediate: oop) and: [(objectMemory isOldObject: oop) and: [objectMemory isWhiteOrBogusGrey: oop]]) ifTrue: + [objectMemory debugger. + ^true]. - [^true]. theSP := theSP + objectMemory wordSize]. (self frameHasContext: theFP) ifTrue: [self assert: (objectMemory isContext: (oop := self frameContext: theFP)). ((objectMemory isOldObject: oop) and: [objectMemory isWhiteOrBogusGrey: oop]) ifTrue: + [objectMemory debugger. + ^true]]. - [^true]]. ((objectMemory isOldObject: (oop := self frameMethodObject: theFP)) and: [objectMemory isWhiteOrBogusGrey: oop]) ifTrue: + [objectMemory debugger. + ^true]. - [^true]. (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue: [theSP := theFP + FoxCallerSavedIP + objectMemory wordSize. theFP := callerFP]. theSP := self isCog ifTrue: [theFP + FoxCallerSavedIP + objectMemory wordSize] "caller ip is ceBaseReturnPC" ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame" [theSP <= thePage baseAddress] whileTrue: [oop := stackPages longAt: theSP. ((objectMemory isNonImmediate: oop) and: [(objectMemory isOldObject: oop) and: [objectMemory isWhiteOrBogusGrey: oop]]) ifTrue: + [objectMemory debugger. + ^true]. - [^true]. theSP := theSP + objectMemory wordSize]. ^false! Item was added: + ----- Method: StackInterpreterPrimitives>>primitiveGCCounters (in category 'system control primitives') ----- + primitiveGCCounters + <staticallyResolveReceiver: 'objectMemory gc' to: #SpurIncrementalGarbageCollector> + + | result | + argumentCount >0 ifTrue: + [^self primitiveFailFor: PrimErrBadNumArgs]. + + result := objectMemory instantiateClass: objectMemory classArray indexableSize: 6. + objectMemory gc gcCounters: result. + self methodReturnValue: result! Item was changed: ----- Method: VMMaker class>>generateSqueakSpurIncrementalStack64VM (in category 'configurations') ----- generateSqueakSpurIncrementalStack64VM "No primitives since we can use those from the Cog VM" ^VMMaker generate: StackInterpreter with: #(ObjectMemory Spur64BitMemoryManager FailImbalancedPrimitives false MULTIPLEBYTECODESETS true + TempVectReadBarrier true - "TempVectReadBarrier true" gcClass SpurIncrementalGarbageCollector bytecodeTableInitializer initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid) to: self sourceTree, '/src/spur64.stack' platformDir: self sourceTree, '/platforms' including: #()!

1 0

VM Maker: VMMaker.oscog.seperateMarking-WoC.3328.mcz
by commits＠source.squeak.org 12 Jun '23

12 Jun '23

Tom Braun uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog.seperateMarking-WoC.3328.mcz ==================== Summary ==================== Name: VMMaker.oscog.seperateMarking-WoC.3328 Author: WoC Time: 12 June 2023, 11:37:49.755091 am UUID: d2b640db-b252-42ce-be4d-6aa7d1b28b6b Ancestors: VMMaker.oscog.seperateMarking-eem.3327 First step to enable generating JIT VM (currently not working) - extracted resolving polymorphism into class PolymorphicResolver - pass class between code generators to share information on polymorphism add helpers to generate Incremental vms on VM class (the usual generate...) extrated generational barrier into method on the StopTheWorldVM added unused optimizations (need debugging): - remove lilliputian chunks all at once at the end of a sweeping pass (in rare cases causes inifinite loop in the code) + add all new free segments after removing the lilliputian chunks - a bitmap for marking classes (why: much more objects than classes and everytime the marker has to look up the class index and then dereference the class objects -> only set a bit for the class index; needs performance benchmarking, because I implemented a smaller bitmap than there are classes) - introduce the time limit of 5 ms in the code for the components - some debug code stays in the code - trigger incrementalGC after a certain memory growth or if there are still compacted segments with unresolved forwarders - compact only every second gc cycle to avoid endless triggering the gc although only copying between segments - unremember forwarders during compacting (they still could be remembered and after freeing the segment after marking the scavenger would try to read the address) - always refresh data on saved segments before a gc pass. (Saving segmentInfo* is a bad mistake I made, because they are in an array and get moved. This invalidated my pointer to them) - add generation of call graph (a helper for me to export the VMs callgraph and use it with tools like Neo4j to analyze the graph) =============== Diff against VMMaker.oscog.seperateMarking-eem.3327 =============== Item was changed: SystemOrganization addCategory: #'VMMaker-Building'! SystemOrganization addCategory: #'VMMaker-Interpreter'! SystemOrganization addCategory: #'VMMaker-InterpreterSimulation'! SystemOrganization addCategory: #'VMMaker-JIT'! SystemOrganization addCategory: #'VMMaker-JITSimulation'! SystemOrganization addCategory: #'VMMaker-Multithreading'! SystemOrganization addCategory: #'VMMaker-Plugins'! SystemOrganization addCategory: #'VMMaker-Plugins-FFI'! SystemOrganization addCategory: #'VMMaker-Plugins-IOS'! SystemOrganization addCategory: #'VMMaker-PostProcessing'! SystemOrganization addCategory: #'VMMaker-SmartSyntaxPlugins'! SystemOrganization addCategory: #'VMMaker-SpurGarbageCollector'! - SystemOrganization addCategory: #'VMMaker-SpurGarbageCollectorSimulation'! SystemOrganization addCategory: #'VMMaker-SpurMemoryManager'! SystemOrganization addCategory: #'VMMaker-SpurMemoryManagerSimulation'! SystemOrganization addCategory: #'VMMaker-Support'! SystemOrganization addCategory: #'VMMaker-Tests'! SystemOrganization addCategory: #'VMMaker-Translation to C'! SystemOrganization addCategory: #'VMMaker-Utilities'! SystemOrganization addCategory: #'VMMaker-V3MemoryManager'! Item was changed: Object subclass: #CCodeGenerator + instanceVariableNames: 'vmClass structClasses translationDict asArgumentTranslationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods apiVariables kernelReturnTypes currentMethod headerFiles globalVariableUsage useSymbolicConstants generateDeadCode requiredSelectors previousCommentMarksInlining previousCommenter logger suppressAsmLabels asmLabelCounts pools selectorTranslations staticallyResolvedPolymorphicReceivers recursivelyResolvedPolymorphicReceivers optionsDictionary breakSrcInlineSelectors breakDestInlineSelectors breakOnInline vmMaker accessorDepthCache beganInlining mappingForRecursivePolymophism removedForPolymorphism recursivePolymorphicMethodsMap toGenerate classesToBeGenerated polymorphicResolver' - instanceVariableNames: 'vmClass structClasses translationDict asArgumentTranslationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods apiVariables kernelReturnTypes currentMethod headerFiles globalVariableUsage useSymbolicConstants generateDeadCode requiredSelectors previousCommentMarksInlining previousCommenter logger suppressAsmLabels asmLabelCounts pools selectorTranslations staticallyResolvedPolymorphicReceivers recursivelyResolvedPolymorphicReceivers optionsDictionary breakSrcInlineSelectors breakDestInlineSelectors breakOnInline vmMaker accessorDepthCache beganInlining mappingForRecursivePolymophism removedForPolymorphism recursivePolymorphicMethodsMap toGenerate classesToBeGenerated' classVariableNames: 'NoRegParmsInAssertVMs VerbosePolymorphismResolution' 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 removed: - ----- Method: CCodeGenerator>>READMEForExplanationOnStaticPolymorphism (in category 'helpers polymorphic resolving') ----- - READMEForExplanationOnStaticPolymorphism - - "static polymophism enables to have multiple classes with the same methods that get resolved at code generation time - (slang -> C). There are two mechanisms depending on your needs: - - (1) static polymorphism for having multiple classes implementing the same methods and selecting which to generate in which case - (2) static polymorphism to have one class generate multiple variants of the same method - - Why to use: - - (1) You want to keep an object oriented programming scheme in slang. This limits you to uniquely named methods. Should two classes use the methods with the same names and you want to be able to use both variants this enables you to do so. - - (2) Imagine you use (1) and have classes A and B both using static polymorphism. Imagine you have a class C that uses A and/or B and gets used by A and/or B. Lets say C calls a method on A and A calls a method on C. This method on C calls a method implemented by A and B, but because B is the default the method from B will get called here, possibly resulting in invalid behaviour. (2) helps with propagating this info and causes the correct method from A to be called. - - How do you use it: - - (1) In all classes implementing the same methods you want to be able to resolve statically you call in declareCVarsIn: the method CCodeGenerator>>staticallyResolveMethodNamed:forClass:to:. This will remove the method named as the first parameter and rename it to the third parameter. It is important to call this in all classes with this methods so the method names get resolved everywhere. The standard is to generate the third parameter by using (self staticallyResolvePolymorphicSelector: key). For an example see SpurGarbageCollector>>declareCVarsIn:. - - In all classes where you want to use your polymorphic methods you now can call CCodeGenerator>>staticallyResolvedPolymorphicReceiver:to:in: in #declareCVarsIn: to resolve every occurence of the receiver in the first parameter to the class given in the second parameter only in the class given in the third parameter. This means you can define how to resolve receivers for other classes, a feature you should use very carefully as this can be confusing to understand. - - If you want to resolve self to your own class you have to implement #hasPolymorphicSelectors on the class side. If it returns true, all sends with self as the receiver will get resolved to the current class. It is recommended to overwrite staticallyResolvePolymorphicSelector: in this case too, as possibly not all methods get statically resolved and therefore renamed. Internally staticallyResolvePolymorphicSelector: is used to get method name to be used when it is determined a receiver want polymorphic resolving. In this case every call to self would cause resolving the method name, even when it should not be resolved. By overwriting staticallyResolvePolymorphicSelector: to only resolve methods that are present in all classes that should be polymorphic you can avoid this. For an example see SpurGarbageCollector>>staticallyResolvePolymorphicSelector: - - (2) To use call CCodeGenerator>>recursivelyResolvePolymorpicReceiver:toVariants:in:default:. This will result in all methods and the transitive closure of methods using the receiver given as the first parameter to get resolved to a variant for every class given in the collection that is the second parameter. This is done in the class that is the third parameter (you should probably only call this for self) and if no type info is present the method will get resolved to the class given as the fourth parameter (the fourth parameter has to be a class that is part of the collection that is the second parameter). - - Lets call the methods in the transitive closure described above recursive polymorphic methods (rpm). If nothing is known about a rpm it gets resolved to the given default. If the rpm is a part of another rpm that has a defined type it is resolved to the same type. - - You can resolve classes to a specific class part of the recursive polymophism by using CCodeGenerator>>forRecursivePolymorphismResolve:as:. If a method is known to belong to a class that is the first parameter it will get resolved as if it part of the second parameter. This is useful when you know the methods of a class should always be resolved to one specific part (e.g. because it is a helper class for a specific part of an algorithm) - - With the pragma #staticallyResolveMethod:to: you can overwrite how a specific method should be resolved. Helpful when a method should be resolved to a type independent given type information, because some invariants rely one variant of the polymorphic method is always called (takes precedence over all other rules described here!!) - - With the pragma #staticallyResolveReceiver:to: you can define how a receiver should be resolved on a method base. Helpful if you do not want to define how to resolve a receiver for a complete class (CCodeGenerator>>staticallyResolvedPolymorphicReceiver:to:in:) or the algorithm is not able to determine the type of a receiver (e.g because it is hidden behind a call. 'objectMemory gc' would reference the gc defined by objectMemory, but because it is only checked against objectMemory and not gc (because that would require to resolve that too somehow) the algorithm normally would not know how to to reolve it. With the pragma you can define how to resolve 'objectMemory gc' - - Should the algorithm find a call to a method that is polymorphicly defined through (1), but have no type information for it it will cause a halt during resolving. You should then take a look at the comment directly above the halt and hopefully be able to resolve the problem (of you not having defined the type for a call enough (and hopefully not me having made an error))"! Item was removed: - ----- Method: CCodeGenerator>>addPolymorphicVariantsFor:referencing:with:default: (in category 'helpers polymorphic resolving') ----- - addPolymorphicVariantsFor: aTMethod referencing: variableName with: classArray default: defaultClass - - | tMethod | - tMethod := methods at: aTMethod selector. - methods at: aTMethod selector put: (aTMethod asPolymorphicBaseFor: classArray toResolve: variableName default: defaultClass). - classArray - do: [:class | | copy polymorphicMethod | - "self halt." - "make a copy to make sure we get no side effects on the copies" - copy := tMethod fasterDeepCopy. - polymorphicMethod := copy asPolymorphicFor: variableName resolveTo: class. - - (methods at: aTMethod selector ifAbsent: []) ifNotNil: - [:conflict | - ((aTMethod definingClass inheritsFrom: conflict definingClass) - or: [aTMethod definingClass = conflict definingClass]) ifFalse: - [self error: 'Method name conflict: ', aTMethod selector]]. - methods at: polymorphicMethod selector put: polymorphicMethod]! Item was added: + ----- Method: CCodeGenerator>>adoptPolymorphicResolver: (in category 'as yet unclassified') ----- + adoptPolymorphicResolver: resolver + "Adopt data about static polymorphism from previous code generators. + Needed because the generation of StackInterpreter and Cog are seperated" + + polymorphicResolver adopt: resolver! Item was added: + ----- Method: CCodeGenerator>>apiMethods (in category 'accessing') ----- + apiMethods + + ^ apiMethods! Item was changed: ----- Method: CCodeGenerator>>buildCallGraph (in category 'call graph') ----- buildCallGraph | graph | graph := Dictionary new. + self halt. - methods do: [:m | m parseTree nodesWithParentsDo: [:node :parent| node isSend ifTrue: [ methods at: node selector ifPresent: [:innerMethod | graph at: innerMethod definingClass -> innerMethod selector ifPresent: [:set | set add: m definingClass -> m selector] ifAbsentPut: [Set with: m definingClass -> m selector] ]]]]. ^ graph! Item was added: + ----- Method: CCodeGenerator>>buildForwardCallGraph (in category 'call graph') ----- + buildForwardCallGraph + + | graph | + graph := Dictionary new. + + self assert: (methods keys intersection: apiMethods keys) isEmpty. + (methods, apiMethods) do: + [:m | + m selector = #markAndTraceLiteral:in:at: ifTrue: [self halt]. + m parseTree nodesWithParentsDo: + [:node :parent| + node isSend ifTrue: [ + methods at: node selector + ifPresent: [:innerMethod | + graph + at: m definingClass -> m selector + ifPresent: [:set | set add: innerMethod definingClass -> innerMethod selector] + ifAbsentPut: [Set with: innerMethod definingClass -> innerMethod selector]]]]]. + + ^ graph! Item was added: + ----- Method: CCodeGenerator>>buildForwardCallGraphFrom:and: (in category 'call graph') ----- + buildForwardCallGraphFrom: stackCC and: cogCC + + | graph methods cogMethods stackMethods | + graph := Dictionary new. + + self assert: (stackCC methods keys intersection: stackCC apiMethods keys) isEmpty. + self assert: (cogCC methods keys intersection: cogCC apiMethods keys) isEmpty. + stackMethods := stackCC methods , stackCC apiMethods. + cogMethods := cogCC methods , cogCC apiMethods. + + "there is some overlap between the two. As I theorize in this case the cog variants get generated we take these + ones" + methods := stackMethods , cogMethods. + + stackMethods do: + [:m | + m parseTree nodesWithParentsDo: + [:node :parent| + node isSend ifTrue: [ + stackMethods at: node selector + ifPresent: [:innerMethod | + graph + at: m definingClass -> m selector + ifPresent: [:set | set add: innerMethod definingClass -> innerMethod selector] + ifAbsentPut: [Set with: innerMethod definingClass -> innerMethod selector]]]]]. + + cogMethods do: + [:m | + m parseTree nodesWithParentsDo: + [:node :parent| + node isSend ifTrue: [ + methods at: node selector + ifPresent: [:innerMethod | + graph + at: m definingClass -> m selector + ifPresent: [:set | set add: innerMethod definingClass -> innerMethod selector] + ifAbsentPut: [Set with: innerMethod definingClass -> innerMethod selector]]]]]. + + ^ graph! Item was added: + ----- Method: CCodeGenerator>>buildReducedCallGraphForGC (in category 'call graph') ----- + buildReducedCallGraphForGC + + | interestingClasses graph keysToDelete set | + interestingClasses := Set newFrom: {SpurIncrementalGarbageCollector . SpurStopTheWorldGarbageCollector . SpurGarbageCollector . SpurMarker . SpurAllAtOnceMarker . SpurIncrementalMarker . SpurCompactor . SpurIncrementalCompactor . SpurIncrementalSweepAndCompact . SpurIncrementalSweeper . SpurPlanningCompactor}. + + graph := self + filterCallGraph: self buildCallGraph + for: interestingClasses. + + keysToDelete := OrderedCollection new. + set := Set new. + + graph keysDo: [:assoc | | key | + key := assoc key. + (interestingClasses includes: key) + ifTrue: [keysToDelete add: assoc. + set addAll: (graph at: assoc)]]. + + self halt. + + graph at: #GC put: set. + keysToDelete do: [:key | + graph removeKey: key]. + + ^ graph! Item was changed: ----- Method: CCodeGenerator>>createAndWriteCallGraph (in category 'call graph') ----- createAndWriteCallGraph + | vmm cg cogCg callGraph cogCallGraph sharedKeys graph | - | vmm cg | vmm := (VMMaker forPlatform: 'Cross') + interpreterClass: CoInterpreter; - interpreterClass: StackInterpreter; options: #(ObjectMemory Spur64BitCoMemoryManager + TempVectReadBarrier true + Cogit StackToRegisterMappingCogit + gcClass SpurIncrementalGarbageCollector). - TempVectReadBarrier true). cg := [vmm buildCodeGeneratorForInterpreter] on: Notification do: [:ex| ex tag == #getVMMaker ifTrue: [ex resume: vmm] ifFalse: [ex pass]]. cg vmClass preGenerationHook: cg. cg inferTypesForImplicitlyTypedVariablesAndMethods. cg prepareMethods. + + cogCg := (VMMaker forPlatform: 'Cross') + interpreterClass: CoInterpreter; + options: #(ObjectMemory Spur64BitCoMemoryManager + ISA ARMv8 + TempVectReadBarrier true + MULTIPLEBYTECODESETS true) , {#Cogit. #StackToRegisterMappingCogit}; + buildCodeGeneratorForCogit. + + cogCg vmClass preGenerationHook: cogCg. + cogCg inferTypesForImplicitlyTypedVariablesAndMethods. + cogCg retainMethods: { #compactCogCompiledCode }. + cogCg prepareMethods. + callGraph := cg buildForwardCallGraph. + cogCallGraph := cogCg buildForwardCallGraph. + + + graph := Dictionary new. + sharedKeys := callGraph keys intersection: cogCallGraph keys. + + callGraph keysAndValuesDo: [:key :value | (sharedKeys includes: key) ifFalse: [graph at: key put: value]]. + cogCallGraph keysAndValuesDo: [:key :value | (sharedKeys includes: key) ifFalse: [graph at: key put: value]]. + + sharedKeys do: [:ea | graph at: ea put: ((callGraph at: ea) , (cogCallGraph at: ea))]. + + self halt. + + cg writeCallGraphCSV: graph! - cg writeCallGraphCSV: cg buildCallGraphForGC! Item was added: + ----- Method: CCodeGenerator>>createAndWriteCogCallGraph (in category 'call graph') ----- + createAndWriteCogCallGraph + + | vmm cg cogCg graph | + vmm := (VMMaker forPlatform: 'Cross') + interpreterClass: CoInterpreter; + options: #(ObjectMemory Spur64BitCoMemoryManager + TempVectReadBarrier true + Cogit StackToRegisterMappingCogit + gcClass SpurIncrementalGarbageCollector). + cg := [vmm buildCodeGeneratorForInterpreter] + on: Notification + do: [:ex| + ex tag == #getVMMaker + ifTrue: [ex resume: vmm] + ifFalse: [ex pass]]. + + cg vmClass preGenerationHook: cg. + cg inferTypesForImplicitlyTypedVariablesAndMethods. + cg prepareMethods. + + + + cogCg := (VMMaker forPlatform: 'Cross') + interpreterClass: CoInterpreter; + options: #(ObjectMemory Spur64BitCoMemoryManager + ISA ARMv8 + TempVectReadBarrier true + MULTIPLEBYTECODESETS true) , {#Cogit. #StackToRegisterMappingCogit}; + instVarNamed: #sharedResolver put: cg polymorphicResolverForAdoption; + buildCodeGeneratorForCogit. + + cogCg vmClass preGenerationHook: cogCg. + cogCg inferTypesForImplicitlyTypedVariablesAndMethods. + cogCg retainMethods: { #compactCogCompiledCode }. + cogCg prepareMethods. + + graph := self buildForwardCallGraphFrom: cg and: cogCg. + + cg writeCallGraphCSV: graph! Item was added: + ----- Method: CCodeGenerator>>createAndWriteReducedCallGraph (in category 'call graph') ----- + createAndWriteReducedCallGraph + + | vmm cg callGraph | + vmm := (VMMaker forPlatform: 'Cross') + interpreterClass: StackInterpreter; + options: #(ObjectMemory Spur64BitCoMemoryManager + TempVectReadBarrier true + Cogit StackToRegisterMappingCogit + gcClass SpurIncrementalGarbageCollector). + cg := [vmm buildCodeGeneratorForInterpreter] + on: Notification + do: [:ex| + ex tag == #getVMMaker + ifTrue: [ex resume: vmm] + ifFalse: [ex pass]]. + + cg vmClass preGenerationHook: cg. + cg inferTypesForImplicitlyTypedVariablesAndMethods. + cg prepareMethods. + + callGraph := cg buildReducedCallGraphForGC. + cg writeCallGraphCSV: callGraph! Item was changed: ----- Method: CCodeGenerator>>forRecursivePolymorphismResolve:as: (in category 'public') ----- forRecursivePolymorphismResolve: aClass as: anotherClass + polymorphicResolver forRecursivePolymorphismResolve: aClass as: anotherClass! - (mappingForRecursivePolymophism ifNil: [mappingForRecursivePolymophism := Dictionary new]) - at: aClass - put: anotherClass! Item was removed: - ----- Method: CCodeGenerator>>getClassFor:in: (in category 'helpers polymorphic resolving') ----- - getClassFor: receiverSymbol in: aClass - - ^ (receiverSymbol = 'self' and: [aClass hasPolymorphicSelectors]) - ifTrue: [aClass] - ifFalse: [staticallyResolvedPolymorphicReceivers - at: aClass - ifPresent: [:dictionary | dictionary at: receiverSymbol ifAbsent: [nil]] - ifAbsent: [nil]]! Item was removed: - ----- Method: CCodeGenerator>>getClassFromPragmasIn:ifMatching: (in category 'helpers polymorphic resolving') ----- - getClassFromPragmasIn: aTMethod ifMatching: receiverSymbol - - ^ (aTMethod pragmasAt: #staticallyResolveReceiver:to:) - ifNotNil: [:pragmas | - pragmas - detect: [:pragma | receiverSymbol = (pragma argumentAt: 1)] - ifFound: [:pragma | Smalltalk at: (pragma argumentAt: 2)] - ifNone: []]! Item was removed: - ----- Method: CCodeGenerator>>hasPolymorphicMethod:in: (in category 'helpers polymorphic resolving') ----- - hasPolymorphicMethod: aSelector in: aClass - - "do we know the class direcly?" - recursivePolymorphicMethodsMap at: aClass - ifPresent: [:methodMap | (methodMap includes: aSelector) - ifTrue: [^ true]]. - - "do we now any if its superclasses" - ^ aClass allSuperclasses - anySatisfy: [:class | (recursivePolymorphicMethodsMap at: class ifAbsent: [{}]) includes: aSelector]! Item was changed: ----- Method: CCodeGenerator>>ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn:fromMethod:in: (in category 'public') ----- ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn: aSendNode fromMethod: aTMethod in: aClass "We allow a limited amount of polymorphism; if a class chooses, its selectors can be prefixed with a given string to disambiguate. This hack allows us to use two different compaction algorithms with the same API at the same time; the selection being done by a class which holds the flag stating which algorithm is in effect at the current time." + polymorphicResolver isNeeded ifNil: [^self]. - | class receiverSymbol | - staticallyResolvedPolymorphicReceivers ifNil: [^self]. - "for debugging. Please do not remove!!" - "(aTMethod selector = #checkForEventsMayContextSwitch: and: [aSendNode selector = #sufficientSpaceAfterGC:]) ifTrue: [self halt]." + polymorphicResolver + staticallyResolvePolymorphicReceiverThenUpdateSelectorIn: aSendNode + fromMethod: aTMethod + in: aClass! - (aSendNode receiver isVariable - or: [(self hasPolymorphicMethod: aSendNode selector in: aClass ) - or: [removedForPolymorphism includesKey: aSendNode selector]]) - ifFalse: [^self]. - - receiverSymbol := aSendNode receiver name. - - (aTMethod pragmasAt: #staticallyResolveMessagesTo:asIfCalledIn:) - ifNotNil: [:pragmas | - pragmas - detect: [:pragma | receiverSymbol = (pragma argumentAt: 1)] - ifFound: [:pragma | - "methods at: aSendNode selector." - self halt.] - ifNone: []]. - - class := (aTMethod pragmasAt: #staticallyResolveMethod:to:) - ifNotNil: [:pragmas | - pragmas - detect: [:pragma | aSendNode selector = (pragma argumentAt: 1)] - ifFound: [:pragma | "self halt." - self - resolve: aSendNode - to: (Smalltalk at: (pragma argumentAt: 2)) - ifFound: [^self]] - ifNone: []]. - - class := (aTMethod pragmaAt: #declareTypeForStaticPolymorphism:) - ifNotNil: [:pragma | | typeHint classFromHint | - typeHint := pragma argumentAt: 1. - classFromHint := Smalltalk at: (pragma argumentAt: 1). - - "if we look at a polymorphic base method do not resolve it to its default but the type hint if it knows it" - methods at: aSendNode selector - ifPresent: [:method | - method isPolymorphicBase - ifTrue: [(method classes includes: classFromHint) - ifTrue: [ | newSelector | - newSelector := method polymorphicSelectorForClass: classFromHint. - aSendNode setSelectorForPolymorphism: newSelector. - ^ self]]. - method isPolymorphic - ifTrue: [self error: 'Should not happen']]. - - removedForPolymorphism at: aSendNode selector - ifPresent: [:dictionary | - dictionary at: classFromHint - ifPresent: [:selector | - aSendNode - setSelectorForPolymorphism: selector. - ^ self]. - - (mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = classFromHint]) keys - detect: [:key | dictionary includesKey: key] - ifFound: [:clazz | - aSendNode - setSelectorForPolymorphism: (dictionary at: clazz). - ^ self] - - ]]. - - class ifNil: [self resolveRecursivePolymorphism: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: [^ self]]. - - - - class := class ifNil: [self getClassFromPragmasIn: aTMethod ifMatching: receiverSymbol]. - class := class ifNil: [self getClassFor: receiverSymbol in: aClass]. - - class := class ifNil: [ - removedForPolymorphism at: aSendNode selector - ifPresent: [: dict | - "you probably ask yourself: why am I here? This halt is triggered if we were unable to resolve your method, although - it is polymorphic with a very high probability. You either have to declare to which type the method has to be resolved, you - did not implement to method in the class you would it expect to be in (inspect dict and see if the class you would expect is - listed there as a key. If not you did not call staticallyResolveMethodNamed:forClass:to: on the selector in the missing class, please - investigate) or I forgot to include one case if the type should already be known - - Please have a look what aTMethod to know in which method the problem occured and aSendNode to know the call in aTMethod that is not enough defined. Probably you want to include a pragma #staticallyResolveReceiver:to: to define of which type the receiver is. Should the current method be a Polymorphic(Base)TMethod it is probably interesting why resolveRecursivePolymorphism:in:fromMethod:in:ifMatch: above does not resolve it." - - " - For easier debugging: - Browser fullOnClass: aTMethod definingClass selector: aTMethod selector. - " - - self error: 'Could not resolve: ' , aSendNode asString , ' in: ' , aTMethod asString - , '. Possible variants of the methods exist in: ' , dict associations asString]]. - - "we have to find a class to resolve the selector" - class - ifNotNil: [ - aSendNode - setSelectorForPolymorphism: (class staticallyResolvePolymorphicSelector: aSendNode selector)] - - ! Item was changed: ----- Method: CCodeGenerator>>initialize (in category 'initialize-release') ----- initialize translationDict := Dictionary new. inlineList := Array new. constants := Dictionary new: 100. variables := Set new: 100. variableDeclarations := Dictionary new: 100. methods := Dictionary new: 500. kernelReturnTypes := self computeKernelReturnTypes. macros := Dictionary new. self initializeCTranslationDictionary. headerFiles := OrderedCollection new. globalVariableUsage := Dictionary new. useSymbolicConstants := true. generateDeadCode := true. scopeStack := OrderedCollection new. self getLogger. pools := IdentitySet new. selectorTranslations := IdentityDictionary new. accessorDepthCache := IdentityDictionary new. beganInlining := false. suppressAsmLabels := false. previousCommentMarksInlining := false. previousCommenter := nil. breakSrcInlineSelectors := IdentitySet new. breakDestInlineSelectors := IdentitySet new. + classesToBeGenerated := IdentitySet new. + + polymorphicResolver := PolymorphicResolver on: self! - classesToBeGenerated := IdentitySet new! Item was removed: - ----- Method: CCodeGenerator>>isReceiverProbablyPolymorpicSendReturningConstant: (in category 'helpers polymorphic resolving') ----- - isReceiverProbablyPolymorpicSendReturningConstant: aSendNode - - ^ aSendNode receiver isSend - and: [aSendNode receiver oldSelector notNil - and: [methods - at: aSendNode receiver selector - ifPresent: [:method | method isReturnConstant] - ifAbsent: [false]]]! Item was added: + ----- Method: CCodeGenerator>>methods (in category 'accessing') ----- + methods + + ^ methods! Item was added: + ----- Method: CCodeGenerator>>polymorphicResolverForAdoption (in category 'as yet unclassified') ----- + polymorphicResolverForAdoption + + polymorphicResolver additionalMethods: self methods. + ^ polymorphicResolver! Item was changed: ----- Method: CCodeGenerator>>recursivelyResolvePolymorpicReceiver:toVariants:in:default: (in category 'public') ----- recursivelyResolvePolymorpicReceiver: variableName toVariants: classArray in: aClass default: defaultClass - "We allow a limited amount of polymorphism; if a class chooses, its selectors can be - prefixed with a given string to disambiguate. This hack allows us to use two different - compaction algorithms with the same API at the same time; the selection being done - by a class which holds the flag stating which algorithm is in effect at the current time." - | methodsInClass methodsReferencingReceiver missingSelectors notGeneratedMethods oldMissingSelectorsSize | - ((recursivelyResolvedPolymorphicReceivers ifNil: [recursivelyResolvedPolymorphicReceivers := Dictionary new]) - at: aClass - ifAbsentPut: [Dictionary new]) - at: variableName - put: classArray. - - "not generated methods can forward to the polymophic target. Scan them for use, so we can methods that use them include into the transitice closure of referencing methods" - notGeneratedMethods := Dictionary newFrom: (((Pragma allNamed: #doNotGenerate in: aClass) - collect: [:ea | | selector | - selector := ea method selector. - "some methods cannot be converted. Ignore them and print them for the developer to do something about it" - [selector -> (ea method asTranslationMethodOfClass: TMethod)] - on: Error - do: [Transcript showln: selector , ' of notGenerated methods could not be translated to a TMethod. Should it be relevant for polymorphism please fix it'. - selector]]) - select: [:ea | ea isSymbol not]). - - - - methodsInClass := methods select: [:each | each definingClass = aClass]. - methodsReferencingReceiver := methodsInClass select: [:method | (method allReferencedVariablesUsing: self) includes: variableName]. - - missingSelectors := self transitiveClosureOfMethods: methodsReferencingReceiver , notGeneratedMethods in: aClass. - oldMissingSelectorsSize := missingSelectors size. + polymorphicResolver recursivelyResolvePolymorpicReceiver: variableName toVariants: classArray in: aClass default: defaultClass! - "do not start to generate not generated methods now. We just wanted to get their transistive closure" - missingSelectors := missingSelectors copyWithoutAll: notGeneratedMethods keys. - self assert: missingSelectors size = (oldMissingSelectorsSize - notGeneratedMethods size). - - missingSelectors do: [:selector | methods - at: selector - ifPresent: [:method | - (recursivePolymorphicMethodsMap ifNil: [recursivePolymorphicMethodsMap := Dictionary new]) - at: aClass - ifPresent: [:set | set add: method selector] - ifAbsentPut: [Set with: method selector]. - self - addPolymorphicVariantsFor: method - referencing: variableName - with: classArray - default: defaultClass] - ifAbsent: []].! Item was changed: ----- Method: CCodeGenerator>>recursivelyResolvePolymorpicReceiver:toVariants:in:default:forMethodList: (in category 'public') ----- recursivelyResolvePolymorpicReceiver: variableName toVariants: classArray in: aClass default: defaultClass forMethodList: aMethodCollection - "We allow a limited amount of polymorphism; if a class chooses, its selectors can be - prefixed with a given string to disambiguate. This hack allows us to use two different - compaction algorithms with the same API at the same time; the selection being done - by a class which holds the flag stating which algorithm is in effect at the current time." - ((recursivelyResolvedPolymorphicReceivers ifNil: [recursivelyResolvedPolymorphicReceivers := Dictionary new]) - at: aClass - ifAbsentPut: [Dictionary new]) - at: variableName - put: classArray. + polymorphicResolver recursivelyResolvePolymorpicReceiver: variableName toVariants: classArray in: aClass default: defaultClass forMethodList: aMethodCollection! - aMethodCollection do: [:selector | methods - at: selector - ifPresent: [:method | - (recursivePolymorphicMethodsMap ifNil: [recursivePolymorphicMethodsMap := Dictionary new]) - at: aClass - ifPresent: [:set | set add: method selector] - ifAbsentPut: [Set with: method selector]. - self - addPolymorphicVariantsFor: method - referencing: variableName - with: classArray - default: defaultClass] - ifAbsent: []].! Item was removed: - ----- Method: CCodeGenerator>>resolve:inSelfSend:in:to:ifFound: (in category 'helpers polymorphic resolving') ----- - resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: receiverClass ifFound: aReturnBlock - - (receiverSymbol = 'self' and: [self hasPolymorphicMethod: aSendNode selector in: aClass]) - ifTrue: [ - aSendNode - setSelectorForPolymorphism: ((methods at: aSendNode selector) polymorphicSelectorForClass: receiverClass). - aReturnBlock value]! Item was removed: - ----- Method: CCodeGenerator>>resolve:to:ifFound: (in category 'helpers polymorphic resolving') ----- - resolve: aSendNode to: receiverClass ifFound: aReturnBlock - - | newSelector | - newSelector := methods - at: aSendNode selector - ifPresent: [:method | (method isPolymorphic or: [method isPolymorphicBase]) - ifTrue: [method polymorphicSelectorForClass: receiverClass] - ifFalse: [nil]] - ifAbsent: ["when a class uses normal static polymorphism it removes selectors in favour of the prefixed ones. - Lookup if this is the case here, if so resolve to the one specific to receiverClass" - removedForPolymorphism - at: aSendNode selector - ifPresent: [:mapping | mapping at: receiverClass ifAbsent: [nil]] - ifAbsent: [nil]]. - newSelector - ifNotNil: [aSendNode - setSelectorForPolymorphism: newSelector. - aReturnBlock value] ! Item was removed: - ----- Method: CCodeGenerator>>resolvePolymorphicMethod:in:fromMethod:in:ifMatch: (in category 'helpers polymorphic resolving') ----- - resolvePolymorphicMethod: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: aReturnBlock - - self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: aTMethod receiverClass ifFound: aReturnBlock. - - receiverSymbol = aTMethod receiverToResolve - ifTrue: [self resolve: aSendNode to: aTMethod receiverClass ifFound: aReturnBlock]. - - "now get desperate. look if there is a method with the selectors name that is mentioned in a polymorphic context" - removedForPolymorphism at: aSendNode selector - ifPresent: [:dictionary | dictionary at: aTMethod receiverClass - ifPresent: [:selector | - aSendNode - setSelectorForPolymorphism: selector. - aReturnBlock value]. - - "is the TMethods receiverClass associated with one of the polymorphic classes implementing aSendNode selector?" - (mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = aTMethod receiverClass]) keys - detect: [:key | dictionary keys anySatisfy: [:ea | key includesBehavior: ea]] - ifFound: [:class | | actualClass | - actualClass := dictionary keys detect: [:ea | class includesBehavior: ea]. - aSendNode - setSelectorForPolymorphism: (dictionary at: actualClass). - aReturnBlock value]]. - - (self hasPolymorphicMethod: aSendNode selector in: aTMethod receiverClass) - ifTrue: [self halt]! Item was removed: - ----- Method: CCodeGenerator>>resolvePolymorphicMethod:in:to:on:in:ifMatch: (in category 'helpers polymorphic resolving') ----- - resolvePolymorphicMethod: receiverSymbol in: aSendNode to: receiverClass on: receiverToResolve in: aClass ifMatch: aReturnBlock - - self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: receiverClass ifFound: aReturnBlock. - - receiverSymbol = receiverToResolve - ifTrue: [self resolve: aSendNode to: receiverClass ifFound: aReturnBlock]. - - "now get desperate. look if there is a method with the selectors name that is mentioned in a polymorphic context" - removedForPolymorphism at: aSendNode selector - ifPresent: [:dictionary | dictionary at: receiverClass - ifPresent: [:selector | - aSendNode - setSelectorForPolymorphism: selector. - aReturnBlock value]. - - "is the TMethods receiverClass associated with one of the polymorphic classes implementing aSendNode selector?" - (mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = receiverClass]) keys - detect: [:key | dictionary includesKey: key] - ifFound: [:class | - aSendNode - setSelectorForPolymorphism: (dictionary at: class). - aReturnBlock value]]. - - (self hasPolymorphicMethod: aSendNode selector in: receiverClass) - ifTrue: [self halt]! Item was removed: - ----- Method: CCodeGenerator>>resolveRecursivePolymorphism:in:fromMethod:in:ifMatch: (in category 'helpers polymorphic resolving') ----- - resolveRecursivePolymorphism: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: aReturnBlock - - "- if the current TMethod is a base method we want to resolve it to the default - - if the current TMethod is a polymorphic method, meaning it got a type to resolve for, apply this type to submethods - - if the called method (from SendNode) is a polymorphic base method we resolve it to the default if we are not in a class associated with only one type. Should this be the case we resolve the method to this type" - - "((aTMethod selector = #globalGarbageCollect) and: [aSendNode selector = #preGlobalGCActions]) ifTrue: [0 halt]." - - aTMethod isPolymorphicBase - ifTrue: [self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: aTMethod default ifFound: aReturnBlock. - - "if the polymorphic receiver is mentioned we resolve the method to the default" - self resolve: aSendNode to: aTMethod default ifFound: aReturnBlock. - - - "now get desperate. look if there is a method with the selectors name that is mentioned in a polymorphic context" - removedForPolymorphism at: aSendNode selector - ifPresent: [:dictionary | dictionary at: aTMethod default - ifPresent: [:selector | - aSendNode - setSelectorForPolymorphism: selector. - aReturnBlock value]. - - "is the TMethods receiverClass associated with one of the polymorphic classes implementing aSendNode selector?" - (mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = aTMethod default]) keys - detect: [:key | dictionary keys anySatisfy: [:ea | key includesBehavior: ea]] - ifFound: [:class | | actualClass | - actualClass := dictionary keys detect: [:ea | class includesBehavior: ea]. - aSendNode - setSelectorForPolymorphism: (dictionary at: actualClass). - aReturnBlock value]]. - - (self hasPolymorphicMethod: aSendNode selector in: aTMethod default) - ifTrue: [self halt]]. - - aTMethod isPolymorphic - ifTrue: [self resolvePolymorphicMethod: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: aReturnBlock]. - - methods at: aSendNode selector - ifPresent: [:calledMethod | - calledMethod isPolymorphicBase - ifTrue: [ | alternativeClass matchingClass | - "we have type info and the calledMethod does not care which type it is -> use type info" - aTMethod isPolymorphic - ifTrue: [ - aSendNode - setSelectorForPolymorphism: (calledMethod polymorphicSelectorForClass: aTMethod receiverClass). - aReturnBlock value ]. - - "should we or one of our superclasses define the called method use the default because we call it ourself and there is no other info" - self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: calledMethod default ifFound: aReturnBlock. - - "should the class be mapped to a fixed type use it to resolve the type of the method" - alternativeClass := mappingForRecursivePolymophism at: aClass ifAbsent: [nil]. - (calledMethod classes includes: aClass) - ifTrue: [matchingClass := aClass] - ifFalse: [(calledMethod classes includes: alternativeClass) - ifTrue: [matchingClass := alternativeClass]]. - matchingClass ifNotNil: [ - aSendNode - setSelectorForPolymorphism: (calledMethod polymorphicSelectorForClass: matchingClass). - aReturnBlock value]. - - "we have no info about the method, but we know it is a polymorphic base -> resolve to default because we assume everyone wants the default" - VerbosePolymorphismResolution ifTrue: - [Transcript show: 'Resolved ' , aSendNode asString. - aSendNode setSelectorForPolymorphism: (calledMethod polymorphicSelectorForClass: calledMethod default). - Transcript - show: ' to ' , aSendNode asString , ' in ' , aTMethod asString , ' because it is the default for the defined polymorphic method.'; - cr]. - aReturnBlock value - ]] - ifAbsent: [] .! Item was changed: ----- Method: CCodeGenerator>>staticallyResolveMethodNamed:forClass:to: (in category 'public') ----- staticallyResolveMethodNamed: selector forClass: aClass to: staticallyResolvedSelector - "We allow a limited amount of polymorphism; if a class chooses, its selectors can be - prefixed with a given string to disambiguate. This hack allows us to use two different - compaction algorithms with the same API at the same time; the selection being done - by a class which holds the flag stating which algorithm is in effect at the current time." - | method | - method := methods - removeKey: selector - ifAbsent: - ["self halt. "self logger cr; nextPutAll: 'warning: did not find ', selector, ' to be able to map to ', staticallyResolvedSelector. - ^self]. - method selector: staticallyResolvedSelector. - methods at: staticallyResolvedSelector put: method. + polymorphicResolver staticallyResolveMethodNamed: selector forClass: aClass to: staticallyResolvedSelector - (removedForPolymorphism ifNil: [removedForPolymorphism := Dictionary new]) - at: selector - ifPresent: [:set | set at: aClass put: staticallyResolvedSelector ] - ifAbsentPut: [Dictionary with: aClass -> staticallyResolvedSelector] ! Item was changed: ----- Method: CCodeGenerator>>staticallyResolvedPolymorphicReceiver:to:in: (in category 'public') ----- staticallyResolvedPolymorphicReceiver: variableName to: aClass in: theClassWithTheVariable + + polymorphicResolver staticallyResolvedPolymorphicReceiver: variableName to: aClass in: theClassWithTheVariable! - "We allow a limited amount of polymorphism; if a class chooses, its selectors can be - prefixed with a given string to disambiguate. This hack allows us to use two different - compaction algorithms with the same API at the same time; the selection being done - by a class which holds the flag stating which algorithm is in effect at the current time." - ((staticallyResolvedPolymorphicReceivers ifNil: [staticallyResolvedPolymorphicReceivers := Dictionary new]) - at: theClassWithTheVariable - ifAbsentPut: [Dictionary new]) - at: variableName - put: aClass! Item was removed: - ----- Method: CCodeGenerator>>transitiveClosureOfMethods:in: (in category 'helpers polymorphic resolving') ----- - transitiveClosureOfMethods: aTMethodDictionary in: aClass - - | alreadySeenSelectors toVisit toVisitNext classes mappingSendsToSelectors | - alreadySeenSelectors := Set newFrom: aTMethodDictionary keys. - toVisit := OrderedCollection newFrom: aTMethodDictionary keys. - toVisitNext := OrderedCollection new. - - - mappingSendsToSelectors := Dictionary new. - classes := (aClass withAllSuperclasses copyUpTo: VMClass). - - classes do: [:ea | - ea selectorsAndMethodsDo: [:selector :method | - - method - selectorsDo: [:sel | - mappingSendsToSelectors - at: sel - ifPresent: [:collection | collection add: selector] - ifAbsentPut: [OrderedCollection with: selector]]]]. - - mappingSendsToSelectors. - - [toVisit do: [:ea | - mappingSendsToSelectors at: ea - ifPresent: [:collection | collection - do: [:sender | - (alreadySeenSelectors includes: sender) - ifFalse: [alreadySeenSelectors add: sender. - toVisitNext add: sender]]]]. - toVisit := toVisitNext. - toVisitNext := OrderedCollection new. - - toVisit notEmpty] whileTrue. - - - - "old much slower code. When tested for StackInterpreter there were 3 methods difference. From a first glance I - could not determine why they should be included, but should the future show I simply overlooked something here the - old code for reference - - [toVisit - do: [:each | (SystemNavigation default allCallsOn: each fromBehaviors: (aClass withAllSuperclasses copyUpTo: VMClass) sorted: false) - do: [:method | |selector | - selector := method selector. - (alreadySeenSelectors includes: selector) - ifFalse: [ - selector = #getenv: ifTrue: [self halt]. - alreadySeenSelectors add: selector. - toVisitNext add: selector] ]]. - toVisit := toVisitNext. - toVisitNext := OrderedCollection new. - - toVisit notEmpty] whileTrue." - - ^ alreadySeenSelectors! Item was changed: ----- Method: CCodeGenerator>>writeCallGraphCSV: (in category 'call graph') ----- writeCallGraphCSV: connections FileStream fileNamed: 'output.csv' do: [:file| file nextPutAll: 'caller'; tab; + nextPutAll: 'callerClass'; + tab; + nextPutAll: 'callerMethod'; + tab; + nextPutAll: 'callerCategory'; + tab; nextPutAll: 'callee'; + tab; + nextPutAll: 'calleeClass'; + tab; + nextPutAll: 'calleeMethod'; + tab; + nextPutAll: 'calleeCategory'; cr; lf. + connections keysAndValuesDo: [:caller :callees | - connections keysAndValuesDo: [:callee :callers | "self halt." + callees do: [:callee | - callers do: [:caller | file nextPutAll: caller asString; tab; + nextPutAll: caller key asString; + tab; + nextPutAll: caller value asString; + tab; + nextPutAll: caller key category asString; + tab; nextPutAll: callee asString; + tab; + nextPutAll: callee key asString; + tab; + nextPutAll: callee value asString; + tab; + nextPutAll: callee key category asString; cr; lf]]]. ^ connections! Item was changed: ----- Method: CoInterpreter class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator "Override to avoid repeating StackInterpreter's declarations and add our own extensions" self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses" aCCodeGenerator addHeaderFile:'"sqCogStackAlignment.h"'; addHeaderFile:'"cogmethod.h"'. NewspeakVM ifTrue: [aCCodeGenerator addHeaderFile:'"nssendcache.h"']. aCCodeGenerator addHeaderFile: (aCCodeGenerator vmClass isThreadedVM ifTrue: ['"cointerpmt.h"'] ifFalse: ['"cointerp.h"']); addHeaderFile:'"cogit.h"'. aCCodeGenerator vmClass declareInterpreterVersionIn: aCCodeGenerator defaultName: aCCodeGenerator interpreterVersion. aCCodeGenerator var: #cogCodeSize type: #usqInt; var: #heapBase type: #usqInt; var: #statCodeCompactionUsecs type: #usqLong; var: #maxLiteralCountForCompile declareC: 'sqInt maxLiteralCountForCompile = MaxLiteralCountForCompile /* ', MaxLiteralCountForCompile printString, ' */'; var: #minBackwardJumpCountForCompile declareC: 'sqInt minBackwardJumpCountForCompile = MinBackwardJumpCountForCompile /* ', MinBackwardJumpCountForCompile printString, ' */'. aCCodeGenerator removeVariable: 'atCache'; "Way too much trouble than it's worth in the Cog VM" removeVariable: 'reenterInterpreter'. "We can use the JIT and CFrame/StrackPointer for a lighter-weight solution." aCCodeGenerator removeVariable: #primitiveAccessorDepthTable. aCCodeGenerator vmClass objectMemoryClass hasSpurMemoryManagerAPI ifTrue: [aCCodeGenerator var: #primitiveMetadataTable type: 'signed short' sizeString: 'MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */' array: (aCCodeGenerator vmClass primitiveMetadataTableUsing: aCCodeGenerator)] ifFalse: [aCCodeGenerator removeVariable: #primitiveMetadataTable]. aCCodeGenerator var: #primTraceLogIndex type: #'unsigned char'; var: #primTraceLog declareC: 'sqInt primTraceLog[256]'; var: #traceLog declareC: 'sqInt traceLog[TraceBufferSize /* ', TraceBufferSize printString, ' */]'; var: 'primTracePluginName' type: #'char *'; var: #traceSources type: #'char *' array: TraceSources. aCCodeGenerator var: #CFramePointer type: #'volatile usqIntptr_t'; var: #CStackPointer type: #'volatile usqIntptr_t'; + var: #CReturnAddress type: #'volatile usqIntptr_t'. + + SpurMemoryManager wantsIncrementalGC + ifTrue: [ + aCCodeGenerator + recursivelyResolvePolymorpicReceiver: 'objectMemory' toVariants: {SpurIncrementalGarbageCollector. SpurStopTheWorldGarbageCollector} in: self default: SpurIncrementalGarbageCollector forMethodList: #(mapInterpreterOops mapStackPages mapVMRegisters mapProfileState) + ]! - var: #CReturnAddress type: #'volatile usqIntptr_t'! Item was added: + ----- Method: CoInterpreter>>incrementalMarkAndTraceMachineCodeMethod: (in category 'gc -- mark and sweep') ----- + incrementalMarkAndTraceMachineCodeMethod: aCogMethod + <var: #aCogMethod type: #'CogBlockMethod *'> + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> + | homeMethod | + <var: #homeMethod type: #'CogMethod *'> + homeMethod := self asCogHomeMethod: aCogMethod. + objectMemory pushOnMarkingStackAndMakeGrey: homeMethod methodObject! Item was changed: ----- Method: CoInterpreter>>incrementalMarkAndTraceTraceLog (in category 'object memory support') ----- incrementalMarkAndTraceTraceLog "The trace log is a circular buffer of pairs of entries. If there is an entry at traceLogIndex - 3 \\ TraceBufferSize it has entries. If there is something at traceLogIndex it has wrapped." <inline: false> + | limit | - <staticallyResolveReceiver: 'marker' to: #SpurIncrementalMarker> - | limit marker | - "do not remove. Necessary for resolving polymorphic receiver" - marker := objectMemory marker. - limit := self safe: traceLogIndex - 3 mod: TraceBufferSize. (traceLog at: limit) = 0 ifTrue: [^self]. (traceLog at: traceLogIndex) ~= 0 ifTrue: [limit := TraceBufferSize - 3]. 0 to: limit by: 3 do: [:i| | oop | oop := traceLog at: i. (objectMemory isImmediate: oop) ifFalse: + [objectMemory markAndScan: oop]. - [marker markAndShouldScan: oop]. oop := traceLog at: i + 1. (objectMemory isImmediate: oop) ifFalse: + [objectMemory markAndScan: oop]]! - [marker markAndShouldScan: oop]]! Item was added: + ----- Method: CogObjectRepresentationFor32BitSpur>>incrementalMarkAndTraceCacheTagLiteral:in:atpc: (in category 'garbage collection') ----- + incrementalMarkAndTraceCacheTagLiteral: literal in: cogMethodOrNil atpc: address + "Mark and trace a literal in an inline cache preceding address in cogMethodOrNil. + Answer if code was modified." + <var: #cogMethodOrNil type: #'CogMethod *'> + <var: #address type: #usqInt> + | objOop | + (self couldBeObject: literal) ifFalse: + [^false]. + self assert: (objectMemory addressCouldBeObj: literal). + (objectMemory isForwarded: literal) ifFalse: + [objectMemory pushOnMarkingStackAndMakeGrey: literal. + ^false]. + objOop := objectMemory followForwarded: literal. + self setCodeModified. + cogit backEnd rewriteInlineCacheTag: objOop at: address. + self incrementalMarkAndTraceUpdatedLiteral: objOop in: cogMethodOrNil. + ^true! Item was changed: ----- Method: CogObjectRepresentationForSpur class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCodeGen aCodeGen var: #ceStoreTrampolines + declareC: '#if IMMUTABILITY\sqInt ceStoreTrampolines[', NumStoreTrampolines printString, '];\#endif'. + + SpurMemoryManager wantsIncrementalGC + ifTrue: [ + "0 halt." + aCodeGen + recursivelyResolvePolymorpicReceiver: 'objectMemory' toVariants: {SpurIncrementalGarbageCollector. SpurStopTheWorldGarbageCollector} in: self default: SpurIncrementalGarbageCollector forMethodList: #(remapObject: remapOop:)]! - declareC: '#if IMMUTABILITY\sqInt ceStoreTrampolines[', NumStoreTrampolines printString, '];\#endif'! Item was added: + ----- Method: CogObjectRepresentationForSpur>>incrementalMarkAndTraceLiteral: (in category 'incremental garbage collection') ----- + incrementalMarkAndTraceLiteral: literal + (self couldBeObject: literal) ifTrue: + [self assert: (objectMemory addressCouldBeObj: literal). + objectMemory gc pushOnMarkingStackAndMakeGrey: literal]! Item was added: + ----- Method: CogObjectRepresentationForSpur>>incrementalMarkAndTraceLiteral:in:at: (in category 'incremental garbage collection') ----- + incrementalMarkAndTraceLiteral: literal in: cogMethod at: address + "Mark and trace a literal in a sqInt variable of cogMethod." + <var: #cogMethod type: #'CogMethod *'> + <var: #address type: #'sqInt *'> + | objOop | + (self couldBeObject: literal) ifFalse: + [^self]. + self assert: (objectMemory addressCouldBeObj: literal). + (objectMemory isForwarded: literal) ifFalse: + [objectMemory gc pushOnMarkingStackAndMakeGrey: literal. + ^self]. + objOop := objectMemory followForwarded: literal. + address at: 0 put: objOop. + self incrementalMarkAndTraceUpdatedLiteral: objOop in: cogMethod! Item was added: + ----- Method: CogObjectRepresentationForSpur>>incrementalMarkAndTraceLiteral:in:atpc: (in category 'incremental garbage collection') ----- + incrementalMarkAndTraceLiteral: literal in: cogMethodOrNil atpc: address + "Mark and trace a literal in a machine code instruction preceding address in cogMethodOrNil. + Answer if code was modified." + <var: #cogMethodOrNil type: #'CogMethod *'> + <var: #address type: #usqInt> + | objOop | + (self couldBeObject: literal) ifFalse: + [^false]. + self assert: (objectMemory addressCouldBeObj: literal). + (objectMemory isForwarded: literal) ifFalse: + [objectMemory pushOnMarkingStackAndMakeGrey: literal. + ^false]. + cogit setCodeModified. + objOop := objectMemory followForwarded: literal. + cogit backEnd storeLiteral: objOop beforeFollowingAddress: address. + self incrementalMarkAndTraceUpdatedLiteral: objOop in: cogMethodOrNil. + ^true! Item was added: + ----- Method: CogObjectRepresentationForSpur>>incrementalMarkAndTraceLiteralIfYoung: (in category 'incremental garbage collection') ----- + incrementalMarkAndTraceLiteralIfYoung: literal + ((self couldBeObject: literal) + and: [objectMemory isYoungObject: literal]) ifTrue: + [self assert: (objectMemory addressCouldBeObj: literal). + objectMemory pushOnMarkingStackAndMakeGrey: literal]! Item was added: + ----- Method: CogObjectRepresentationForSpur>>incrementalMarkAndTraceUpdatedLiteral:in: (in category 'incremental garbage collection') ----- + incrementalMarkAndTraceUpdatedLiteral: objOop in: cogMethodOrNil + "Common code to mark a literal in cogMethod and add + the cogMethod to youngReferrers if the literal is young." + <var: #cogMethodOrNil type: #'CogMethod *'> + (objectMemory isNonImmediate: objOop) ifTrue: + [(cogMethodOrNil notNil + and: [objectMemory isYoungObject: objOop]) ifTrue: + [methodZone ensureInYoungReferrers: cogMethodOrNil]. + objectMemory pushOnMarkingStackAndMakeGrey: objOop]! Item was changed: ----- Method: CogObjectRepresentationForSpur>>markAndTraceLiteral: (in category 'garbage collection') ----- markAndTraceLiteral: literal + + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> (self couldBeObject: literal) ifTrue: [self assert: (objectMemory addressCouldBeObj: literal). objectMemory markAndTrace: literal]! Item was changed: ----- Method: CogObjectRepresentationForSpur>>markAndTraceLiteral:in:at: (in category 'garbage collection') ----- markAndTraceLiteral: literal in: cogMethod at: address "Mark and trace a literal in a sqInt variable of cogMethod." + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> <var: #cogMethod type: #'CogMethod *'> <var: #address type: #'sqInt *'> | objOop | (self couldBeObject: literal) ifFalse: [^self]. self assert: (objectMemory addressCouldBeObj: literal). (objectMemory isForwarded: literal) ifFalse: [objectMemory markAndTrace: literal. ^self]. objOop := objectMemory followForwarded: literal. address at: 0 put: objOop. self markAndTraceUpdatedLiteral: objOop in: cogMethod! Item was changed: ----- Method: CogObjectRepresentationForSpur>>markAndTraceLiteral:in:atpc: (in category 'garbage collection') ----- markAndTraceLiteral: literal in: cogMethodOrNil atpc: address "Mark and trace a literal in a machine code instruction preceding address in cogMethodOrNil. Answer if code was modified." + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> <var: #cogMethodOrNil type: #'CogMethod *'> <var: #address type: #usqInt> | objOop | (self couldBeObject: literal) ifFalse: [^false]. self assert: (objectMemory addressCouldBeObj: literal). (objectMemory isForwarded: literal) ifFalse: [objectMemory markAndTrace: literal. ^false]. cogit setCodeModified. objOop := objectMemory followForwarded: literal. cogit backEnd storeLiteral: objOop beforeFollowingAddress: address. self markAndTraceUpdatedLiteral: objOop in: cogMethodOrNil. ^true! Item was changed: ----- Method: CogObjectRepresentationForSpur>>markAndTraceLiteralIfYoung: (in category 'garbage collection') ----- markAndTraceLiteralIfYoung: literal + + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> ((self couldBeObject: literal) and: [objectMemory isYoungObject: literal]) ifTrue: [self assert: (objectMemory addressCouldBeObj: literal). objectMemory markAndTrace: literal]! Item was changed: ----- Method: CogObjectRepresentationForSpur>>markAndTraceUpdatedLiteral:in: (in category 'garbage collection') ----- markAndTraceUpdatedLiteral: objOop in: cogMethodOrNil "Common code to mark a literal in cogMethod and add the cogMethod to youngReferrers if the literal is young." + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> <var: #cogMethodOrNil type: #'CogMethod *'> (objectMemory isNonImmediate: objOop) ifTrue: [(cogMethodOrNil notNil and: [objectMemory isYoungObject: objOop]) ifTrue: [methodZone ensureInYoungReferrers: cogMethodOrNil]. objectMemory markAndTrace: objOop]! Item was changed: ----- Method: Cogit class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator | backEnd | backEnd := CogCompilerClass basicNew. #( 'coInterpreter' 'objectMemory' 'methodZone' 'objectRepresentation' 'cogBlockMethodSurrogateClass' 'cogMethodSurrogateClass' 'nsSendCacheSurrogateClass' 'threadManager' 'processor' 'lastNInstructions' 'simulatedAddresses' 'ioHighResClock' 'simulatedTrampolines' 'simulatedVariableGetters' 'simulatedVariableSetters' 'processorFrameValid' 'printRegisters' 'printInstructions' 'clickConfirm' 'clickStepping' 'singleStep' 'codeZoneIsExecutableNotWritable' 'debugAPISelector' 'shortCutTrampolineBlocks' 'perMethodProfile' 'instructionProfile') do: [:simulationVariableUnusedByRealVM| aCCodeGenerator removeVariable: simulationVariableUnusedByRealVM]. NewspeakVM ifFalse: [#( 'selfSendTrampolines' 'dynamicSuperSendTrampolines' 'implicitReceiverSendTrampolines' 'outerSendTrampolines' 'ceEnclosingObjectTrampoline' 'numIRCs' 'indexOfIRC' 'theIRCs') do: [:variableNotNeededInNormalVM| aCCodeGenerator removeVariable: variableNotNeededInNormalVM]]. aCCodeGenerator removeConstant: #COGMTVM. "this should be defined at compile time" "N.B. We *do not* include sq.h; it pulls in conflicting definitions now that sqVirtualMachine.h declares cointerp's functions, and declares some of them inaccurately for histrical reasons. We pull in CoInterpreter's api via cointerp.h which is accurate." aCCodeGenerator addHeaderFile:'"sqConfig.h"'; "config.h must be first on linux" addHeaderFile:'<stddef.h>'; "for e.g. offsetof" addHeaderFile:'<stdio.h>'; addHeaderFile:'<stdlib.h>'; addHeaderFile:'<string.h>'; addHeaderFile:'"sqPlatformSpecific.h"'; "e.g. solaris overrides things for sqCogStackAlignment.h" addHeaderFile:'"sqMemoryAccess.h"'; addHeaderFile:'"sqCogStackAlignment.h"'; addHeaderFile:'"dispdbg.h"'; "must precede cointerp.h & cogit.h otherwise NoDbgRegParms gets screwed up" addHeaderFile:'"cogmethod.h"'. NewspeakVM ifTrue: [aCCodeGenerator addHeaderFile:'"nssendcache.h"']. aCCodeGenerator addHeaderFile:'#if COGMTVM'; addHeaderFile:'"cointerpmt.h"'; addHeaderFile:'#else'; addHeaderFile:'"cointerp.h"'; addHeaderFile:'#endif'; addHeaderFile:'"cogit.h"'. aCCodeGenerator var: #ceGetFP declareC: 'usqIntptr_t (*ceGetFP)(void)'; var: #ceGetSP declareC: 'usqIntptr_t (*ceGetSP)(void)'; var: #ceCaptureCStackPointers declareC: 'void (*ceCaptureCStackPointers)(void)'; var: #ceInvokeInterpret declareC: 'void (*ceInvokeInterpret)(void)'; var: #ceEnterCogCodePopReceiverReg declareC: 'void (*ceEnterCogCodePopReceiverReg)(void)'; var: #realCEEnterCogCodePopReceiverReg declareC: 'void (*realCEEnterCogCodePopReceiverReg)(void)'; var: #ceCallCogCodePopReceiverReg declareC: 'void (*ceCallCogCodePopReceiverReg)(void)'; var: #realCECallCogCodePopReceiverReg declareC: 'void (*realCECallCogCodePopReceiverReg)(void)'; var: #ceCallCogCodePopReceiverAndClassRegs declareC: 'void (*ceCallCogCodePopReceiverAndClassRegs)(void)'; var: #realCECallCogCodePopReceiverAndClassRegs declareC: 'void (*realCECallCogCodePopReceiverAndClassRegs)(void)'; var: #postCompileHook declareC: 'void (*postCompileHook)(CogMethod *)'; var: #openPICList declareC: 'CogMethod *openPICList = 0'; var: #maxMethodBefore type: #'CogBlockMethod *'; var: 'enumeratingCogMethod' type: #'CogMethod *'. aCCodeGenerator var: #ceTryLockVMOwner declareC: '#if COGMTVM\usqIntptr_t (*ceTryLockVMOwner)(usqIntptr_t)\#endif'. backEnd numICacheFlushOpcodes > 0 ifTrue: [aCCodeGenerator var: #ceFlushICache declareC: 'static void (*ceFlushICache)(usqIntptr_t from, usqIntptr_t to)']. aCCodeGenerator var: #ceFlushDCache declareC: '#if DUAL_MAPPED_CODE_ZONE\static void (*ceFlushDCache)(usqIntptr_t from, usqIntptr_t to)\#endif'; var: #codeToDataDelta declareC: '#if DUAL_MAPPED_CODE_ZONE\static sqInt codeToDataDelta\#else\# define codeToDataDelta 0\#endif'; var: #cFramePointerInUse declareC: '#if !!defined(cFramePointerInUse)\sqInt cFramePointerInUse\#endif'. aCCodeGenerator declareVar: 'aMethodLabel' type: #'AbstractInstruction'; "Has to come lexicographically before backEnd & methodLabel" var: #backEnd declareC: 'AbstractInstruction * const backEnd = &aMethodLabel'; var: #methodLabel declareC: 'AbstractInstruction * const methodLabel = &aMethodLabel'. self declareC: #(abstractOpcodes stackCheckLabel blockEntryLabel blockEntryNoContextSwitch stackOverflowCall sendMiss entry noCheckEntry selfSendEntry dynSuperEntry fullBlockNoContextSwitchEntry fullBlockEntry picMNUAbort picInterpretAbort endCPICCase0 endCPICCase1 cPICEndOfCodeLabel) as: #'AbstractInstruction *' in: aCCodeGenerator. aCCodeGenerator declareVar: #cPICPrototype type: #'CogMethod *'; declareVar: #blockStarts type: #'BlockStart *'; declareVar: #fixups type: #'BytecodeFixup *'; declareVar: #methodZoneBase type: #usqInt. aCCodeGenerator var: #ordinarySendTrampolines declareC: 'sqInt ordinarySendTrampolines[NumSendTrampolines]'; var: #superSendTrampolines declareC: 'sqInt superSendTrampolines[NumSendTrampolines]'. BytecodeSetHasDirectedSuperSend ifTrue: [aCCodeGenerator var: #directedSuperSendTrampolines declareC: 'sqInt directedSuperSendTrampolines[NumSendTrampolines]'; var: #directedSuperBindingSendTrampolines declareC: 'sqInt directedSuperBindingSendTrampolines[NumSendTrampolines]']. NewspeakVM ifTrue: [aCCodeGenerator var: #selfSendTrampolines declareC: 'sqInt selfSendTrampolines[NumSendTrampolines]'; var: #dynamicSuperSendTrampolines declareC: 'sqInt dynamicSuperSendTrampolines[NumSendTrampolines]'; var: #implicitReceiverSendTrampolines declareC: 'sqInt implicitReceiverSendTrampolines[NumSendTrampolines]'; var: #outerSendTrampolines declareC: 'sqInt outerSendTrampolines[NumSendTrampolines]']. aCCodeGenerator addConstantForBinding: self bindingForNumTrampolines; var: #trampolineAddresses declareC: 'static char *trampolineAddresses[NumTrampolines*2]'; var: #objectReferencesInRuntime declareC: 'static usqInt objectReferencesInRuntime[NumObjRefsInRuntime+1]'; var: #labelCounter type: #int; var: #traceFlags declareC: 'int traceFlags = 8 /* prim trace log on by default */'; declareVar: #traceFlagsMeanings type: #'const char *'; var: #traceFlagsMeanings declareC: (CCodeGenerator new arrayInitializerCalled: #traceFlagsMeanings for: ((Cogit basicNew sendTrace: -1)) sizeString: nil type: #'const char *'); var: #cStackAlignment declareC: 'const int cStackAlignment = STACK_ALIGN_BYTES'. aCCodeGenerator declareVar: #minValidCallAddress type: #'usqIntptr_t'. aCCodeGenerator vmClass generatorTable ifNotNil: [:bytecodeGenTable| aCCodeGenerator var: #generatorTable declareC: 'static BytecodeDescriptor generatorTable[', bytecodeGenTable size printString, ']', (self tableInitializerFor: bytecodeGenTable in: aCCodeGenerator)]. "In C the abstract opcode names clash with the Smalltalk generator syntactic sugar. Most of the syntactic sugar is inlined, but alas some remains. Rename the syntactic sugar to avoid the clash." (self organization listAtCategoryNamed: #'abstract instructions') do: [:s| aCCodeGenerator addSelectorTranslation: s to: 'g', (aCCodeGenerator cFunctionNameFor: s)]. aCCodeGenerator addSelectorTranslation: #halt: to: 'haltmsg'. + self declareFlagVarsAsByteIn: aCCodeGenerator.! - self declareFlagVarsAsByteIn: aCCodeGenerator! Item was changed: ----- Method: Cogit>>followForwardedLiteralsImplementationIn: (in category 'garbage collection & become') ----- followForwardedLiteralsImplementationIn: cogMethod <option: #SpurObjectMemory> + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> <var: #cogMethod type: #'CogMethod *'> | writableCogMethod hasYoungObj hasYoungObjPtr | self assert: (cogMethod isCMMethodEtAl not or: [(objectMemory isForwarded: cogMethod methodObject) not]). writableCogMethod := self writableMethodFor: cogMethod. hasYoungObj := objectMemory isYoung: cogMethod methodObject. (objectMemory shouldRemapOop: cogMethod selector) ifTrue: [writableCogMethod selector: (objectMemory remapObj: cogMethod selector). (objectMemory isYoung: cogMethod selector) ifTrue: [hasYoungObj := true]]. hasYoungObjPtr := (self addressOf: hasYoungObj put: [:val| hasYoungObj := val]) asInteger. self mapFor: cogMethod performUntil: #remapIfObjectRef:pc:hasYoung: arg: hasYoungObjPtr asVoidPointer. hasYoungObj ifTrue: [methodZone ensureInYoungReferrers: cogMethod] ifFalse: [writableCogMethod cmRefersToYoung: false]! Item was added: + ----- Method: Cogit>>incrementakMarkYoungObjectsIn: (in category 'garbage collection & become') ----- + incrementakMarkYoungObjectsIn: cogMethod + "Mark young literals in the method." + <var: #cogMethod type: #'CogMethod *'> + <inline: true> + self assert: (cogMethod isCMMethodEtAl + or: [cogMethod isCMOpenPIC]). + (objectMemory isYoung: cogMethod selector) ifTrue: + [objectMemory markAndScan: cogMethod selector]. + (cogMethod isCMMethodEtAl + and: [objectMemory isYoung: cogMethod methodObject]) ifTrue: + [objectMemory markAndScan: cogMethod methodObject]. + self mapFor: cogMethod + performUntil: #incrementalMarkYoungObjects:pc:method: + arg: cogMethod! Item was added: + ----- Method: Cogit>>incrementalMarkAndTraceMachineCodeForNewSpaceGC (in category 'jit - api') ----- + incrementalMarkAndTraceMachineCodeForNewSpaceGC + "Free any methods that refer to unmarked objects, unlinking sends to freed methods." + | pointer cogMethod | + <var: #cogMethod type: #'CogMethod *'> + objectMemory leakCheckNewSpaceGC ifTrue: + [self asserta: 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 isCMMethodEtAl + or: [cogMethod isCMOpenPIC]). + (objectMemory isYoung: cogMethod selector) ifTrue: + [objectMemory markAndScan: cogMethod selector]. + cogMethod isCMMethodEtAl ifTrue: + [(objectMemory isYoung: cogMethod methodObject) ifTrue: + [objectMemory markAndScan: cogMethod methodObject]. + self markYoungObjectsIn: cogMethod]]. + pointer := pointer + objectMemory wordSize]. + objectMemory leakCheckNewSpaceGC ifTrue: + [self asserta: self allMachineCodeObjectReferencesValid]. + codeModified ifTrue: "After updating oops in inline caches we need to flush the icache." + [backEnd flushICacheFrom: methodZoneBase asUnsignedInteger to: methodZone freeStart]! Item was added: + ----- Method: Cogit>>incrementalMarkAndTraceObjectReferencesInGeneratedRuntime (in category 'jit - api') ----- + incrementalMarkAndTraceObjectReferencesInGeneratedRuntime + "Mark and trace any object references in the generated run-time." + 0 to: runtimeObjectRefIndex - 1 do: + [:i| | mcpc literal | + mcpc := objectReferencesInRuntime at: i. + literal := literalsManager fetchLiteralAtAnnotatedAddress: mcpc using: backEnd. + objectRepresentation + incrementalMarkAndTraceLiteral: literal + in: (self cCoerceSimple: nil to: #'CogMethod *') + atpc: mcpc asUnsignedInteger]! Item was added: + ----- Method: Cogit>>incrementalMarkLiterals:pc:method: (in category 'garbage collection') ----- + incrementalMarkLiterals: annotation pc: mcpc method: cogMethod + "Mark and trace literals. + Additionally in Newspeak, void push implicits that have unmarked classes." + <var: #mcpc type: #'char *'> + <var: #cogMethod type: #'CogMethod *'> + <var: #nsSendCache type: #'NSSendCache *'> + | literal | + annotation = IsObjectReference ifTrue: + [literal := literalsManager fetchLiteralAtAnnotatedAddress: mcpc asUnsignedInteger using: backEnd. + (objectRepresentation incrementalMarkAndTraceLiteral: literal in: cogMethod atpc: mcpc asUnsignedInteger) ifTrue: + [codeModified := true]]. + + NewspeakVM ifTrue: + [annotation = IsNSSendCall ifTrue: + [| nsSendCache sel eo | + nsSendCache := self nsSendCacheFromReturnAddress: mcpc asInteger. + sel := nsSendCache selector. + (objectMemory isForwarded: sel) + ifFalse: [objectMemory markAndScan: sel] + ifTrue: [sel := objectMemory followForwarded: literal. + nsSendCache selector: sel. + self markAndTraceUpdatedLiteral: sel in: (self cCoerceSimple: cogMethod to: #'CogMethod *')]. + eo := nsSendCache enclosingObject. + eo ~= 0 ifTrue: + [(objectMemory isForwarded: eo) + ifFalse: [objectMemory markAndScan: eo] + ifTrue: [eo := objectMemory followForwarded: literal. + nsSendCache enclosingObject: eo. + self incrementalMarkAndTraceUpdatedLiteral: eo in: (self cCoerceSimple: cogMethod to: #'CogMethod *')]]]]. + + (self isPureSendAnnotation: annotation) ifTrue: + [self entryCacheTagAndCouldBeObjectAt: mcpc annotation: annotation into: + [:entryPoint :cacheTag :tagCouldBeObj | + (tagCouldBeObj + and: [objectRepresentation incrementalMarkAndTraceCacheTagLiteral: cacheTag in: cogMethod atpc: mcpc asUnsignedInteger]) ifTrue: + ["cacheTag is selector" codeModified := true]]]. + + ^0 "keep scanning"! Item was added: + ----- Method: Cogit>>incrementalMarkYoungObjectsIn: (in category 'incremental garbage collection') ----- + incrementalMarkYoungObjectsIn: cogMethod + "Mark young literals in the method." + <var: #cogMethod type: #'CogMethod *'> + <inline: true> + self assert: (cogMethod isCMMethodEtAl + or: [cogMethod isCMOpenPIC]). + (objectMemory isYoung: cogMethod selector) ifTrue: + [objectMemory pushOnMarkingStackAndMakeGrey: cogMethod selector]. + (cogMethod isCMMethodEtAl + and: [objectMemory isYoung: cogMethod methodObject]) ifTrue: + [objectMemory pushOnMarkingStackAndMakeGrey: cogMethod methodObject]. + self mapFor: cogMethod + performUntil: #markYoungObjects:pc:method: + arg: cogMethod! Item was added: + ----- Method: Cogit>>incremetalFollowForwardedLiteralsImplementationIn: (in category 'garbage collection & become') ----- + incremetalFollowForwardedLiteralsImplementationIn: cogMethod + <option: #SpurObjectMemory> + <declareTypeForStaticPolymorphism: #SpurIncrementalGarbageCollector> + <var: #cogMethod type: #'CogMethod *'> + | writableCogMethod hasYoungObj hasYoungObjPtr | + self assert: (cogMethod isCMMethodEtAl not or: [(objectMemory isForwarded: cogMethod methodObject) not]). + writableCogMethod := self writableMethodFor: cogMethod. + hasYoungObj := objectMemory isYoung: cogMethod methodObject. + (objectMemory shouldRemapOop: cogMethod selector) ifTrue: + [writableCogMethod selector: (objectMemory remapObj: cogMethod selector). + (objectMemory isYoung: cogMethod selector) ifTrue: + [hasYoungObj := true]]. + hasYoungObjPtr := (self addressOf: hasYoungObj put: [:val| hasYoungObj := val]) asInteger. + self mapFor: cogMethod + performUntil: #remapIfObjectRef:pc:hasYoung: + arg: hasYoungObjPtr asVoidPointer. + hasYoungObj + ifTrue: [methodZone ensureInYoungReferrers: cogMethod] + ifFalse: [writableCogMethod cmRefersToYoung: false]! Item was changed: ----- Method: Cogit>>mapPerMethodProfile (in category 'analysis') ----- mapPerMethodProfile "Simulation only counting of instructions per method/pic/trampoline..." + + "type does not matter as methods does not get generated, but neccessary for code gen process :(" + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> <cmacro: '() 0'> perMethodProfile ifNotNil: [:pmp| | map | "The tricky thing here is that a method may get remapped to another method already in the profile, etc..." map := Dictionary new. pmp keysAndValuesDo: [:methodOopOrCodeThang :count| (methodOopOrCodeThang >= objectMemory startOfMemory and: [objectMemory shouldRemapOop: methodOopOrCodeThang]) ifTrue: [map at: methodOopOrCodeThang put: {objectMemory remapObj: methodOopOrCodeThang. count}]]. map isEmpty ifFalse: [map keysAndValuesDo: [:newOop :tuple| [:oldOop :count| (map includesKey: oldOop) ifFalse: [pmp removeKey: oldOop]. pmp at: newOop put: count] valueWithArguments: tuple]]]! Item was changed: ----- 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 *'> + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> objectMemory leakCheckNewSpaceGC ifTrue: [self asserta: 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 isCMMethodEtAl or: [cogMethod isCMOpenPIC]). (objectMemory isYoung: cogMethod selector) ifTrue: [objectMemory markAndTrace: cogMethod selector]. cogMethod isCMMethodEtAl ifTrue: [(objectMemory isYoung: cogMethod methodObject) ifTrue: [objectMemory markAndTrace: cogMethod methodObject]. self markYoungObjectsIn: cogMethod]]. pointer := pointer + objectMemory wordSize]. objectMemory leakCheckNewSpaceGC ifTrue: [self asserta: self allMachineCodeObjectReferencesValid]. codeModified ifTrue: "After updating oops in inline caches we need to flush the icache." [backEnd flushICacheFrom: methodZoneBase asUnsignedInteger to: methodZone freeStart]! Item was changed: ----- Method: Cogit>>markLiterals:pc:method: (in category 'garbage collection') ----- markLiterals: annotation pc: mcpc method: cogMethod "Mark and trace literals. Additionally in Newspeak, void push implicits that have unmarked classes." <var: #mcpc type: #'char *'> <var: #cogMethod type: #'CogMethod *'> <var: #nsSendCache type: #'NSSendCache *'> + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> | literal | annotation = IsObjectReference ifTrue: [literal := literalsManager fetchLiteralAtAnnotatedAddress: mcpc asUnsignedInteger using: backEnd. (objectRepresentation markAndTraceLiteral: literal in: cogMethod atpc: mcpc asUnsignedInteger) ifTrue: [codeModified := true]]. NewspeakVM ifTrue: [annotation = IsNSSendCall ifTrue: [| nsSendCache sel eo | nsSendCache := self nsSendCacheFromReturnAddress: mcpc asInteger. sel := nsSendCache selector. (objectMemory isForwarded: sel) ifFalse: [objectMemory markAndTrace: sel] ifTrue: [sel := objectMemory followForwarded: literal. nsSendCache selector: sel. self markAndTraceUpdatedLiteral: sel in: (self cCoerceSimple: cogMethod to: #'CogMethod *')]. eo := nsSendCache enclosingObject. eo ~= 0 ifTrue: [(objectMemory isForwarded: eo) ifFalse: [objectMemory markAndTrace: eo] ifTrue: [eo := objectMemory followForwarded: literal. nsSendCache enclosingObject: eo. self markAndTraceUpdatedLiteral: eo in: (self cCoerceSimple: cogMethod to: #'CogMethod *')]]]]. (self isPureSendAnnotation: annotation) ifTrue: [self entryCacheTagAndCouldBeObjectAt: mcpc annotation: annotation into: [:entryPoint :cacheTag :tagCouldBeObj | (tagCouldBeObj and: [objectRepresentation markAndTraceCacheTagLiteral: cacheTag in: cogMethod atpc: mcpc asUnsignedInteger]) ifTrue: ["cacheTag is selector" codeModified := true]]]. ^0 "keep scanning"! Item was changed: ----- Method: Cogit>>markLiteralsAndUnlinkIfUnmarkedSend:pc:method: (in category 'garbage collection') ----- markLiteralsAndUnlinkIfUnmarkedSend: annotation pc: mcpc method: cogMethod "Mark and trace literals. Unlink sends that have unmarked cache tags or targets." <var: #mcpc type: #'char *'> <var: #cogMethod type: #'CogMethod *'> + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> | literal | <var: #nsSendCache type: #'NSSendCache *'> annotation = IsObjectReference ifTrue: [literal := literalsManager fetchLiteralAtAnnotatedAddress: mcpc asUnsignedInteger using: backEnd. (objectRepresentation markAndTraceLiteral: literal in: (self cCoerceSimple: cogMethod to: #'CogMethod *') atpc: mcpc asUnsignedInteger) ifTrue: [codeModified := true]]. NewspeakVM ifTrue: [annotation = IsNSSendCall ifTrue: [| nsSendCache entryPoint targetMethod sel eo | nsSendCache := self nsSendCacheFromReturnAddress: mcpc asInteger. entryPoint := nsSendCache target. entryPoint ~= 0 ifTrue: "Send is linked" [targetMethod := self cCoerceSimple: entryPoint - cmNoCheckEntryOffset to: #'CogMethod *'. (self markAndTraceOrFreeCogMethod: targetMethod firstVisit: targetMethod asUnsignedInteger > mcpc asUnsignedInteger) ifTrue: [self voidNSSendCache: nsSendCache]]. sel := nsSendCache selector. (objectMemory isForwarded: sel) ifFalse: [objectMemory markAndTrace: sel] ifTrue: [sel := objectMemory followForwarded: literal. nsSendCache selector: sel. self markAndTraceUpdatedLiteral: sel in: (self cCoerceSimple: cogMethod to: #'CogMethod *')]. eo := nsSendCache enclosingObject. eo ~= 0 ifTrue: [(objectMemory isForwarded: eo) ifFalse: [objectMemory markAndTrace: eo] ifTrue: [eo := objectMemory followForwarded: literal. nsSendCache enclosingObject: eo. self markAndTraceUpdatedLiteral: eo in: (self cCoerceSimple: cogMethod to: #'CogMethod *')]]]]. (self isPureSendAnnotation: annotation) ifTrue: [self entryCacheTagAndCouldBeObjectAt: mcpc annotation: annotation into: [:entryPoint :cacheTag :tagCouldBeObj | | cacheTagMarked | cacheTagMarked := tagCouldBeObj and: [objectRepresentation cacheTagIsMarked: cacheTag]. entryPoint > methodZoneBase ifTrue: "It's a linked send." [self targetMethodAndSendTableFor: entryPoint annotation: annotation into: [:targetMethod :sendTable| (cacheTagMarked not or: [self markAndTraceOrFreeCogMethod: targetMethod firstVisit: targetMethod asUnsignedInteger > mcpc asUnsignedInteger]) ifTrue: ["Either the cacheTag is unmarked (e.g. new class) or the target has been freed (because it is unmarked), so unlink the send." self unlinkSendAt: mcpc targetMethod: targetMethod sendTable: sendTable. objectRepresentation markAndTraceLiteral: targetMethod selector in: targetMethod at: (self addressOf: targetMethod selector put: [:val| targetMethod selector: val])]]] ifFalse: "cacheTag is selector" [(objectRepresentation markAndTraceCacheTagLiteral: cacheTag in: (self cCoerceSimple: cogMethod to: #'CogMethod *') atpc: mcpc asUnsignedInteger) ifTrue: [codeModified := true]]]]. ^0 "keep scanning"! Item was changed: ----- Method: Cogit>>markYoungObjectsIn: (in category 'garbage collection & become') ----- markYoungObjectsIn: cogMethod "Mark young literals in the method." + <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector> <var: #cogMethod type: #'CogMethod *'> <inline: true> self assert: (cogMethod isCMMethodEtAl or: [cogMethod isCMOpenPIC]). (objectMemory isYoung: cogMethod selector) ifTrue: [objectMemory markAndTrace: cogMethod selector]. (cogMethod isCMMethodEtAl and: [objectMemory isYoung: cogMethod methodObject]) ifTrue: [objectMemory markAndTrace: cogMethod methodObject]. self mapFor: cogMethod performUntil: #markYoungObjects:pc:method: arg: cogMethod! Item was changed: ----- Method: InterpreterPrimitives>>primitiveStoreImageSegment (in category 'image segment in/out') ----- primitiveStoreImageSegment "This primitive is called from Squeak as... <imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray." "This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree). All pointers from within the tree to objects outside the tree will be copied into the array of outpointers. In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 4). but with the high bit set." "The primitive expects the array and wordArray to be more than adequately long. In this case it returns normally, and truncates the two arrays to exactly the right size. To simplify truncation, both incoming arrays are required to be 256 bytes or more long (ie with 3-word headers). If either array is too small, the primitive will fail, but in no other case. During operation of the primitive, it is necessary to convert from both internal and external oops to their mapped values. To make this fast, the headers of the original objects in question are replaced by the mapped values (and this is noted by adding the forbidden XX header type). Tables are kept of both kinds of oops, as well as of the original headers for restoration. To be specific, there are two similar two-part tables, the outpointer array, and one in the upper fifth of the segmentWordArray. Each grows oops from the bottom up, and preserved headers from halfway up. In case of either success or failure, the headers must be restored. In the event of primitive failure, the table of outpointers must also be nilled out (since the garbage in the high half will not have been discarded." + <staticallyResolveReceiver: 'objectMemory' to: #SpurStopTheWorldGarbageCollector> | outPointerArray segmentWordArray arrayOfRoots ecode | outPointerArray := self stackTop. segmentWordArray := self stackValue: 1. arrayOfRoots := self stackValue: 2. "Essential type checks" ((objectMemory isArray: arrayOfRoots) "Must be indexable pointers" and: [(objectMemory isArray: outPointerArray) "Must be indexable pointers" and: [objectMemory isWords: segmentWordArray]]) "Must be indexable words" ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. ecode := objectMemory storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots. (objectMemory hasSpurMemoryManagerAPI and: [ecode = PrimErrNeedCompaction]) ifTrue: [objectMemory fullGC. outPointerArray := self stackTop. segmentWordArray := self stackValue: 1. arrayOfRoots := self stackValue: 2. ecode := objectMemory storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots]. ecode = PrimNoErr ifTrue: [self pop: 3] "...leaving the receiver on the stack as return value" ifFalse: [self primitiveFailFor: ecode]! Item was added: + Object subclass: #PolymorphicResolver + instanceVariableNames: 'generator staticallyResolvedPolymorphicReceivers recursivelyResolvedPolymorphicReceivers mappingForRecursivePolymophism removedForPolymorphism recursivePolymorphicMethodsMap additionalMethods' + classVariableNames: 'VerbosePolymorphismResolution' + poolDictionaries: '' + category: 'VMMaker-Translation to C'! Item was added: + ----- Method: PolymorphicResolver class>>initialize (in category 'as yet unclassified') ----- + initialize + + "Set this to true to get information on polymorphic message resolution printed to the transcript." + VerbosePolymorphismResolution := false! Item was added: + ----- Method: PolymorphicResolver class>>on: (in category 'as yet unclassified') ----- + on: aCCodeGenerator + + ^ self new + generator: aCCodeGenerator; + yourself! Item was added: + ----- Method: PolymorphicResolver>>READMEForExplanationOnStaticPolymorphism (in category 'as yet unclassified') ----- + READMEForExplanationOnStaticPolymorphism + + "static polymophism enables to have multiple classes with the same methods that get resolved at code generation time + (slang -> C). There are two mechanisms depending on your needs: + + (1) static polymorphism for having multiple classes implementing the same methods and selecting which to generate in which case + (2) static polymorphism to have one class generate multiple variants of the same method + + Why to use: + + (1) You want to keep an object oriented programming scheme in slang. This limits you to uniquely named methods. Should two classes use the methods with the same names and you want to be able to use both variants this enables you to do so. + + (2) Imagine you use (1) and have classes A and B both using static polymorphism. Imagine you have a class C that uses A and/or B and gets used by A and/or B. Lets say C calls a method on A and A calls a method on C. This method on C calls a method implemented by A and B, but because B is the default the method from B will get called here, possibly resulting in invalid behaviour. (2) helps with propagating this info and causes the correct method from A to be called. + + How do you use it: + + (1) In all classes implementing the same methods you want to be able to resolve statically you call in declareCVarsIn: the method CCodeGenerator>>staticallyResolveMethodNamed:forClass:to:. This will remove the method named as the first parameter and rename it to the third parameter. It is important to call this in all classes with this methods so the method names get resolved everywhere. The standard is to generate the third parameter by using (self staticallyResolvePolymorphicSelector: key). For an example see SpurGarbageCollector>>declareCVarsIn:. + + In all classes where you want to use your polymorphic methods you now can call CCodeGenerator>>staticallyResolvedPolymorphicReceiver:to:in: in #declareCVarsIn: to resolve every occurence of the receiver in the first parameter to the class given in the second parameter only in the class given in the third parameter. This means you can define how to resolve receivers for other classes, a feature you should use very carefully as this can be confusing to understand. + + If you want to resolve self to your own class you have to implement #hasPolymorphicSelectors on the class side. If it returns true, all sends with self as the receiver will get resolved to the current class. It is recommended to overwrite staticallyResolvePolymorphicSelector: in this case too, as possibly not all methods get statically resolved and therefore renamed. Internally staticallyResolvePolymorphicSelector: is used to get method name to be used when it is determined a receiver want polymorphic resolving. In this case every call to self would cause resolving the method name, even when it should not be resolved. By overwriting staticallyResolvePolymorphicSelector: to only resolve methods that are present in all classes that should be polymorphic you can avoid this. For an example see SpurGarbageCollector>>staticallyResolvePolymorphicSelector: + + (2) To use call CCodeGenerator>>recursivelyResolvePolymorpicReceiver:toVariants:in:default:. This will result in all methods and the transitive closure of methods using the receiver given as the first parameter to get resolved to a variant for every class given in the collection that is the second parameter. This is done in the class that is the third parameter (you should probably only call this for self) and if no type info is present the method will get resolved to the class given as the fourth parameter (the fourth parameter has to be a class that is part of the collection that is the second parameter). + + Lets call the methods in the transitive closure described above recursive polymorphic methods (rpm). If nothing is known about a rpm it gets resolved to the given default. If the rpm is a part of another rpm that has a defined type it is resolved to the same type. + + You can resolve classes to a specific class part of the recursive polymophism by using CCodeGenerator>>forRecursivePolymorphismResolve:as:. If a method is known to belong to a class that is the first parameter it will get resolved as if it part of the second parameter. This is useful when you know the methods of a class should always be resolved to one specific part (e.g. because it is a helper class for a specific part of an algorithm) + + With the pragma #staticallyResolveMethod:to: you can overwrite how a specific method should be resolved. Helpful when a method should be resolved to a type independent given type information, because some invariants rely one variant of the polymorphic method is always called (takes precedence over all other rules described here!!) + + With the pragma #staticallyResolveReceiver:to: you can define how a receiver should be resolved on a method base. Helpful if you do not want to define how to resolve a receiver for a complete class (CCodeGenerator>>staticallyResolvedPolymorphicReceiver:to:in:) or the algorithm is not able to determine the type of a receiver (e.g because it is hidden behind a call. 'objectMemory gc' would reference the gc defined by objectMemory, but because it is only checked against objectMemory and not gc (because that would require to resolve that too somehow) the algorithm normally would not know how to to reolve it. With the pragma you can define how to resolve 'objectMemory gc' + + Should the algorithm find a call to a method that is polymorphicly defined through (1), but have no type information for it it will cause a halt during resolving. You should then take a look at the comment directly above the halt and hopefully be able to resolve the problem (of you not having defined the type for a call enough (and hopefully not me having made an error))"! Item was added: + ----- Method: PolymorphicResolver>>addPolymorphicVariantsFor:referencing:with:default: (in category 'as yet unclassified') ----- + addPolymorphicVariantsFor: aTMethod referencing: variableName with: classArray default: defaultClass + + | tMethod selector | + selector := aTMethod selector. + tMethod := generator methods at: selector. + generator methods at: selector put: (aTMethod asPolymorphicBaseFor: classArray toResolve: variableName default: defaultClass). + classArray + do: [:class | | copy polymorphicMethod | + "self halt." + "make a copy to make sure we get no side effects on the copies" + copy := tMethod fasterDeepCopy. + polymorphicMethod := copy asPolymorphicFor: variableName resolveTo: class. + + (generator methods at: selector ifAbsent: []) ifNotNil: + [:conflict | + ((aTMethod definingClass inheritsFrom: conflict definingClass) + or: [aTMethod definingClass = conflict definingClass]) ifFalse: + [self error: 'Method name conflict: ', selector]]. + generator methods at: polymorphicMethod selector put: polymorphicMethod]! Item was added: + ----- Method: PolymorphicResolver>>additionalMethods (in category 'accessing') ----- + additionalMethods + + ^ additionalMethods! Item was added: + ----- Method: PolymorphicResolver>>additionalMethods: (in category 'accessing') ----- + additionalMethods: anObject + + additionalMethods := anObject.! Item was added: + ----- Method: PolymorphicResolver>>adopt: (in category 'as yet unclassified') ----- + adopt: aPolymorphicResolver + + | properties | + properties := #(removedForPolymorphism staticallyResolvedPolymorphicReceivers recursivelyResolvedPolymorphicReceivers recursivePolymorphicMethodsMap mappingForRecursivePolymophism). + + properties + do: [:property | + self + instVarNamed: property + put: (self mergeIfPresent: (self instVarNamed: property) and: (aPolymorphicResolver instVarNamed: property))]. + + self additionalMethods: self additionalMethods , aPolymorphicResolver additionalMethods! Item was added: + ----- Method: PolymorphicResolver>>forRecursivePolymorphismResolve:as: (in category 'as yet unclassified') ----- + forRecursivePolymorphismResolve: aClass as: anotherClass + + (mappingForRecursivePolymophism ifNil: [mappingForRecursivePolymophism := Dictionary new]) + at: aClass + put: anotherClass! Item was added: + ----- Method: PolymorphicResolver>>generator (in category 'accessing') ----- + generator + + ^ generator! Item was added: + ----- Method: PolymorphicResolver>>generator: (in category 'accessing') ----- + generator: anObject + + generator := anObject.! Item was added: + ----- Method: PolymorphicResolver>>getClassFor:in: (in category 'as yet unclassified') ----- + getClassFor: receiverSymbol in: aClass + + ^ (receiverSymbol = 'self' and: [aClass hasPolymorphicSelectors]) + ifTrue: [aClass] + ifFalse: [staticallyResolvedPolymorphicReceivers + at: aClass + ifPresent: [:dictionary | dictionary at: receiverSymbol ifAbsent: [nil]] + ifAbsent: [nil]]! Item was added: + ----- Method: PolymorphicResolver>>getClassFromPragmasIn:ifMatching: (in category 'as yet unclassified') ----- + getClassFromPragmasIn: aTMethod ifMatching: receiverSymbol + + ^ (aTMethod pragmasAt: #staticallyResolveReceiver:to:) + ifNotNil: [:pragmas | + pragmas + detect: [:pragma | receiverSymbol = (pragma argumentAt: 1)] + ifFound: [:pragma | Smalltalk at: (pragma argumentAt: 2)] + ifNone: []]! Item was added: + ----- Method: PolymorphicResolver>>hasPolymorphicMethod:in: (in category 'testing') ----- + hasPolymorphicMethod: aSelector in: aClass + + "do we know the class direcly?" + recursivePolymorphicMethodsMap at: aClass + ifPresent: [:methodMap | (methodMap includes: aSelector) + ifTrue: [^ true]]. + + "do we now any if its superclasses" + ^ aClass allSuperclasses + anySatisfy: [:class | (recursivePolymorphicMethodsMap at: class ifAbsent: [{}]) includes: aSelector]! Item was added: + ----- Method: PolymorphicResolver>>initialize (in category 'initialize-release') ----- + initialize + + additionalMethods := Dictionary new! Item was added: + ----- Method: PolymorphicResolver>>isNeeded (in category 'testing') ----- + isNeeded + + "quite an easy an inaccurate check. Could be better, but works good enough for now" + + ^ staticallyResolvedPolymorphicReceivers notNil! Item was added: + ----- Method: PolymorphicResolver>>isReceiverProbablyPolymorpicSendReturningConstant: (in category 'as yet unclassified') ----- + isReceiverProbablyPolymorpicSendReturningConstant: aSendNode + + ^ aSendNode receiver isSend + and: [aSendNode receiver oldSelector notNil + and: [self + methodNamed: aSendNode receiver selector + ifPresent: [:method | method isReturnConstant] + ifAbsent: [false]]]! Item was added: + ----- Method: PolymorphicResolver>>mappingForRecursivePolymophism (in category 'accessing') ----- + mappingForRecursivePolymophism + + ^ mappingForRecursivePolymophism! Item was added: + ----- Method: PolymorphicResolver>>mappingForRecursivePolymophism: (in category 'accessing') ----- + mappingForRecursivePolymophism: anObject + + mappingForRecursivePolymophism := anObject.! Item was added: + ----- Method: PolymorphicResolver>>mergeIfPresent:and: (in category 'as yet unclassified') ----- + mergeIfPresent: aCollection and: anotherCollection + + aCollection ifNil: [anotherCollection ifNotNil: [^ anotherCollection]]. + anotherCollection ifNil: [^ aCollection]. + + ^ aCollection , anotherCollection! Item was added: + ----- Method: PolymorphicResolver>>methodNamed: (in category 'method access') ----- + methodNamed: selector + + ^ generator methods + at: selector + ifAbsent: [additionalMethods at: selector] + + ! Item was added: + ----- Method: PolymorphicResolver>>methodNamed:ifPresent: (in category 'method access') ----- + methodNamed: selector ifPresent: presentBlock + + ^ generator methods + at: selector + ifPresent: presentBlock + ifAbsent: [additionalMethods at: selector ifPresent: presentBlock] + + ! Item was added: + ----- Method: PolymorphicResolver>>methodNamed:ifPresent:ifAbsent: (in category 'method access') ----- + methodNamed: selector ifPresent: presentBlock ifAbsent: absentBlock + + ^ generator methods + at: selector + ifPresent: presentBlock + ifAbsent: [additionalMethods + at: selector + ifPresent: presentBlock + ifAbsent: absentBlock] + ! Item was added: + ----- Method: PolymorphicResolver>>methodsSelect: (in category 'method access') ----- + methodsSelect: aBlock + + ^ (generator methods , additionalMethods) select: aBlock + + ! Item was added: + ----- Method: PolymorphicResolver>>recursivePolymorphicMethodsMap (in category 'accessing') ----- + recursivePolymorphicMethodsMap + + ^ recursivePolymorphicMethodsMap! Item was added: + ----- Method: PolymorphicResolver>>recursivePolymorphicMethodsMap: (in category 'accessing') ----- + recursivePolymorphicMethodsMap: anObject + + recursivePolymorphicMethodsMap := anObject.! Item was added: + ----- Method: PolymorphicResolver>>recursivelyResolvePolymorpicReceiver:toVariants:in:default: (in category 'as yet unclassified') ----- + recursivelyResolvePolymorpicReceiver: variableName toVariants: classArray in: aClass default: defaultClass + "We allow a limited amount of polymorphism; if a class chooses, its selectors can be + prefixed with a given string to disambiguate. This hack allows us to use two different + compaction algorithms with the same API at the same time; the selection being done + by a class which holds the flag stating which algorithm is in effect at the current time." + | methodsInClass methodsReferencingReceiver missingSelectors notGeneratedMethods oldMissingSelectorsSize | + ((recursivelyResolvedPolymorphicReceivers ifNil: [recursivelyResolvedPolymorphicReceivers := Dictionary new]) + at: aClass + ifAbsentPut: [Dictionary new]) + at: variableName + put: classArray. + + "not generated methods can forward to the polymophic target. Scan them for use, so we can methods that use them include into the transitice closure of referencing methods" + notGeneratedMethods := Dictionary newFrom: (((Pragma allNamed: #doNotGenerate in: aClass) + collect: [:ea | | selector | + selector := ea method selector. + "some methods cannot be converted. Ignore them and print them for the developer to do something about it" + [selector -> (ea method asTranslationMethodOfClass: TMethod)] + on: Error + do: [Transcript showln: selector , ' of notGenerated methods could not be translated to a TMethod. Should it be relevant for polymorphism please fix it'. + selector]]) + select: [:ea | ea isSymbol not]). + + + + methodsInClass := self methodsSelect: [:each | each definingClass = aClass]. + methodsReferencingReceiver := methodsInClass select: [:method | (method allReferencedVariablesUsing: generator) includes: variableName]. + + missingSelectors := self transitiveClosureOfMethods: methodsReferencingReceiver , notGeneratedMethods in: aClass. + oldMissingSelectorsSize := missingSelectors size. + + "do not start to generate not generated methods now. We just wanted to get their transistive closure" + missingSelectors := missingSelectors copyWithoutAll: notGeneratedMethods keys. + self assert: missingSelectors size = (oldMissingSelectorsSize - notGeneratedMethods size). + + missingSelectors do: [:selector | self + methodNamed: selector + ifPresent: [:method | + (recursivePolymorphicMethodsMap ifNil: [recursivePolymorphicMethodsMap := Dictionary new]) + at: aClass + ifPresent: [:set | set add: method selector] + ifAbsentPut: [Set with: method selector]. + self + addPolymorphicVariantsFor: method + referencing: variableName + with: classArray + default: defaultClass] + ifAbsent: []].! Item was added: + ----- Method: PolymorphicResolver>>recursivelyResolvePolymorpicReceiver:toVariants:in:default:forMethodList: (in category 'as yet unclassified') ----- + recursivelyResolvePolymorpicReceiver: variableName toVariants: classArray in: aClass default: defaultClass forMethodList: aMethodCollection + "We allow a limited amount of polymorphism; if a class chooses, its selectors can be + prefixed with a given string to disambiguate. This hack allows us to use two different + compaction algorithms with the same API at the same time; the selection being done + by a class which holds the flag stating which algorithm is in effect at the current time." + ((recursivelyResolvedPolymorphicReceivers ifNil: [recursivelyResolvedPolymorphicReceivers := Dictionary new]) + at: aClass + ifAbsentPut: [Dictionary new]) + at: variableName + put: classArray. + + aMethodCollection do: [:selector | self + methodNamed: selector + ifPresent: [:method | + (recursivePolymorphicMethodsMap ifNil: [recursivePolymorphicMethodsMap := Dictionary new]) + at: aClass + ifPresent: [:set | set add: method selector] + ifAbsentPut: [Set with: method selector]. + self + addPolymorphicVariantsFor: method + referencing: variableName + with: classArray + default: defaultClass]].! Item was added: + ----- Method: PolymorphicResolver>>recursivelyResolvedPolymorphicReceivers (in category 'accessing') ----- + recursivelyResolvedPolymorphicReceivers + + ^ recursivelyResolvedPolymorphicReceivers! Item was added: + ----- Method: PolymorphicResolver>>recursivelyResolvedPolymorphicReceivers: (in category 'accessing') ----- + recursivelyResolvedPolymorphicReceivers: anObject + + recursivelyResolvedPolymorphicReceivers := anObject.! Item was added: + ----- Method: PolymorphicResolver>>removedForPolymorphism (in category 'accessing') ----- + removedForPolymorphism + + ^ removedForPolymorphism! Item was added: + ----- Method: PolymorphicResolver>>removedForPolymorphism: (in category 'accessing') ----- + removedForPolymorphism: anObject + + removedForPolymorphism := anObject.! Item was added: + ----- Method: PolymorphicResolver>>resolve:inSelfSend:in:to:ifFound: (in category 'as yet unclassified') ----- + resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: receiverClass ifFound: aReturnBlock + + (receiverSymbol = 'self' and: [self hasPolymorphicMethod: aSendNode selector in: aClass]) + ifTrue: [ + aSendNode + setSelectorForPolymorphism: ((self methodNamed: aSendNode selector) polymorphicSelectorForClass: receiverClass). + aReturnBlock value]! Item was added: + ----- Method: PolymorphicResolver>>resolve:to:ifFound: (in category 'as yet unclassified') ----- + resolve: aSendNode to: receiverClass ifFound: aReturnBlock + + | newSelector | + newSelector := self + methodNamed: aSendNode selector + ifPresent: [:method | (method isPolymorphic or: [method isPolymorphicBase]) + ifTrue: [method polymorphicSelectorForClass: receiverClass] + ifFalse: [nil]] + ifAbsent: ["when a class uses normal static polymorphism it removes selectors in favour of the prefixed ones. + Lookup if this is the case here, if so resolve to the one specific to receiverClass" + removedForPolymorphism + at: aSendNode selector + ifPresent: [:mapping | mapping at: receiverClass ifAbsent: [nil]] + ifAbsent: [nil]]. + newSelector + ifNotNil: [aSendNode + setSelectorForPolymorphism: newSelector. + aReturnBlock value] ! Item was added: + ----- Method: PolymorphicResolver>>resolvePolymorphicMethod:in:fromMethod:in:ifMatch: (in category 'as yet unclassified') ----- + resolvePolymorphicMethod: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: aReturnBlock + + self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: aTMethod receiverClass ifFound: aReturnBlock. + + receiverSymbol = aTMethod receiverToResolve + ifTrue: [self resolve: aSendNode to: aTMethod receiverClass ifFound: aReturnBlock]. + + "now get desperate. look if there is a method with the selectors name that is mentioned in a polymorphic context" + removedForPolymorphism at: aSendNode selector + ifPresent: [:dictionary | dictionary at: aTMethod receiverClass + ifPresent: [:selector | + aSendNode + setSelectorForPolymorphism: selector. + aReturnBlock value]. + + "is the TMethods receiverClass associated with one of the polymorphic classes implementing aSendNode selector?" + (mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = aTMethod receiverClass]) keys + detect: [:key | dictionary keys anySatisfy: [:ea | key includesBehavior: ea]] + ifFound: [:class | | actualClass | + actualClass := dictionary keys detect: [:ea | class includesBehavior: ea]. + aSendNode + setSelectorForPolymorphism: (dictionary at: actualClass). + aReturnBlock value]]. + + (self hasPolymorphicMethod: aSendNode selector in: aTMethod receiverClass) + ifTrue: [self halt]! Item was added: + ----- Method: PolymorphicResolver>>resolvePolymorphicMethod:in:to:on:in:ifMatch: (in category 'as yet unclassified') ----- + resolvePolymorphicMethod: receiverSymbol in: aSendNode to: receiverClass on: receiverToResolve in: aClass ifMatch: aReturnBlock + + self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: receiverClass ifFound: aReturnBlock. + + receiverSymbol = receiverToResolve + ifTrue: [self resolve: aSendNode to: receiverClass ifFound: aReturnBlock]. + + "now get desperate. look if there is a method with the selectors name that is mentioned in a polymorphic context" + removedForPolymorphism at: aSendNode selector + ifPresent: [:dictionary | dictionary at: receiverClass + ifPresent: [:selector | + aSendNode + setSelectorForPolymorphism: selector. + aReturnBlock value]. + + "is the TMethods receiverClass associated with one of the polymorphic classes implementing aSendNode selector?" + (mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = receiverClass]) keys + detect: [:key | dictionary includesKey: key] + ifFound: [:class | + aSendNode + setSelectorForPolymorphism: (dictionary at: class). + aReturnBlock value]]. + + (self hasPolymorphicMethod: aSendNode selector in: receiverClass) + ifTrue: [self halt]! Item was added: + ----- Method: PolymorphicResolver>>resolveRecursivePolymorphism:in:fromMethod:in:ifMatch: (in category 'as yet unclassified') ----- + resolveRecursivePolymorphism: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: aReturnBlock + + "- if the current TMethod is a base method we want to resolve it to the default + - if the current TMethod is a polymorphic method, meaning it got a type to resolve for, apply this type to submethods + - if the called method (from SendNode) is a polymorphic base method we resolve it to the default if we are not in a class associated with only one type. Should this be the case we resolve the method to this type" + + "((aTMethod selector = #globalGarbageCollect) and: [aSendNode selector = #preGlobalGCActions]) ifTrue: [0 halt]." + + aTMethod isPolymorphicBase + ifTrue: [self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: aTMethod default ifFound: aReturnBlock. + + "if the polymorphic receiver is mentioned we resolve the method to the default" + self resolve: aSendNode to: aTMethod default ifFound: aReturnBlock. + + + "now get desperate. look if there is a method with the selectors name that is mentioned in a polymorphic context" + removedForPolymorphism at: aSendNode selector + ifPresent: [:dictionary | dictionary at: aTMethod default + ifPresent: [:selector | + aSendNode + setSelectorForPolymorphism: selector. + aReturnBlock value]. + + "is the TMethods receiverClass associated with one of the polymorphic classes implementing aSendNode selector?" + (mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = aTMethod default]) keys + detect: [:key | dictionary keys anySatisfy: [:ea | key includesBehavior: ea]] + ifFound: [:class | | actualClass | + actualClass := dictionary keys detect: [:ea | class includesBehavior: ea]. + aSendNode + setSelectorForPolymorphism: (dictionary at: actualClass). + aReturnBlock value]]. + + (self hasPolymorphicMethod: aSendNode selector in: aTMethod default) + ifTrue: [self halt]]. + + aTMethod isPolymorphic + ifTrue: [self resolvePolymorphicMethod: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: aReturnBlock]. + + self methodNamed: aSendNode selector + ifPresent: [:calledMethod | + calledMethod isPolymorphicBase + ifTrue: [ | alternativeClass matchingClass | + "we have type info and the calledMethod does not care which type it is -> use type info" + aTMethod isPolymorphic + ifTrue: [ + aSendNode + setSelectorForPolymorphism: (calledMethod polymorphicSelectorForClass: aTMethod receiverClass). + aReturnBlock value ]. + + "should we or one of our superclasses define the called method use the default because we call it ourself and there is no other info" + self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: calledMethod default ifFound: aReturnBlock. + + "should the class be mapped to a fixed type use it to resolve the type of the method" + alternativeClass := mappingForRecursivePolymophism at: aClass ifAbsent: [nil]. + (calledMethod classes includes: aClass) + ifTrue: [matchingClass := aClass] + ifFalse: [(calledMethod classes includes: alternativeClass) + ifTrue: [matchingClass := alternativeClass]]. + matchingClass ifNotNil: [ + aSendNode + setSelectorForPolymorphism: (calledMethod polymorphicSelectorForClass: matchingClass). + aReturnBlock value]. + + "we have no info about the method, but we know it is a polymorphic base -> resolve to default because we assume everyone wants the default" + VerbosePolymorphismResolution ifTrue: + [Transcript show: 'Resolved ' , aSendNode asString. + aSendNode setSelectorForPolymorphism: (calledMethod polymorphicSelectorForClass: calledMethod default). + Transcript + show: ' to ' , aSendNode asString , ' in ' , aTMethod asString , ' because it is the default for the defined polymorphic method.'; + cr]. + aReturnBlock value + ]] + ifAbsent: [] .! Item was added: + ----- Method: PolymorphicResolver>>staticallyResolveMethodNamed:forClass:to: (in category 'register polymorphism') ----- + staticallyResolveMethodNamed: selector forClass: aClass to: staticallyResolvedSelector + "We allow a limited amount of polymorphism; if a class chooses, its selectors can be + prefixed with a given string to disambiguate. This hack allows us to use two different + compaction algorithms with the same API at the same time; the selection being done + by a class which holds the flag stating which algorithm is in effect at the current time." + | method | + method := generator methods + removeKey: selector + ifAbsent: + ["self halt. "generator logger cr; nextPutAll: 'warning: did not find ', selector, ' to be able to map to ', staticallyResolvedSelector. + ^self]. + method selector: staticallyResolvedSelector. + generator methods at: staticallyResolvedSelector put: method. + + (removedForPolymorphism ifNil: [removedForPolymorphism := Dictionary new]) + at: selector + ifPresent: [:set | set at: aClass put: staticallyResolvedSelector ] + ifAbsentPut: [Dictionary with: aClass -> staticallyResolvedSelector] + ! Item was added: + ----- Method: PolymorphicResolver>>staticallyResolvePolymorphicReceiverThenUpdateSelectorIn:fromMethod:in: (in category 'as yet unclassified') ----- + staticallyResolvePolymorphicReceiverThenUpdateSelectorIn: aSendNode fromMethod: aTMethod in: aClass + + | class receiverSymbol | + "for debugging. Please do not remove!!" + "(aTMethod selector = #checkForEventsMayContextSwitch: and: [aSendNode selector = #sufficientSpaceAfterGC:]) ifTrue: [self halt]." + + (aSendNode receiver isVariable + or: [(self hasPolymorphicMethod: aSendNode selector in: aClass ) + or: [removedForPolymorphism includesKey: aSendNode selector]]) + ifFalse: [^self]. + + receiverSymbol := aSendNode receiver name. + + class := (aTMethod pragmasAt: #staticallyResolveMethod:to:) + ifNotNil: [:pragmas | + pragmas + detect: [:pragma | aSendNode selector = (pragma argumentAt: 1)] + ifFound: [:pragma | "self halt." + self + resolve: aSendNode + to: (Smalltalk at: (pragma argumentAt: 2)) + ifFound: [^self]] + ifNone: []]. + + class := (aTMethod pragmaAt: #declareTypeForStaticPolymorphism:) + ifNotNil: [:pragma | | typeHint classFromHint | + typeHint := pragma argumentAt: 1. + classFromHint := Smalltalk at: (pragma argumentAt: 1). + + "if we look at a polymorphic base method do not resolve it to its default but the type hint if it knows it" + self methodNamed: aSendNode selector + ifPresent: [:method | + method isPolymorphicBase + ifTrue: [(method classes includes: classFromHint) + ifTrue: [ | newSelector | + newSelector := method polymorphicSelectorForClass: classFromHint. + aSendNode setSelectorForPolymorphism: newSelector. + ^ self]]. + method isPolymorphic + ifTrue: [self error: 'Should not happen']]. + + removedForPolymorphism at: aSendNode selector + ifPresent: [:dictionary | + dictionary at: classFromHint + ifPresent: [:selector | + aSendNode + setSelectorForPolymorphism: selector. + ^ self]. + + (mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = classFromHint]) keys + detect: [:key | dictionary includesKey: key] + ifFound: [:clazz | + aSendNode + setSelectorForPolymorphism: (dictionary at: clazz). + ^ self] + + ]]. + + class ifNil: [self resolveRecursivePolymorphism: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: [^ self]]. + + + + class := class ifNil: [self getClassFromPragmasIn: aTMethod ifMatching: receiverSymbol]. + class := class ifNil: [self getClassFor: receiverSymbol in: aClass]. + + class := class ifNil: [ + removedForPolymorphism at: aSendNode selector + ifPresent: [: dict | + "you probably ask yourself: why am I here? This halt is triggered if we were unable to resolve your method, although + it is polymorphic with a very high probability. You either have to declare to which type the method has to be resolved, you + did not implement to method in the class you would it expect to be in (inspect dict and see if the class you would expect is + listed there as a key. If not you did not call staticallyResolveMethodNamed:forClass:to: on the selector in the missing class, please + investigate) or I forgot to include one case if the type should already be known + + Please have a look what aTMethod to know in which method the problem occured and aSendNode to know the call in aTMethod that is not enough defined. Probably you want to include a pragma #staticallyResolveReceiver:to: to define of which type the receiver is. Should the current method be a Polymorphic(Base)TMethod it is probably interesting why resolveRecursivePolymorphism:in:fromMethod:in:ifMatch: above does not resolve it." + + " + For easier debugging: + Browser fullOnClass: aTMethod definingClass selector: aTMethod selector. + " + + self error: 'Could not resolve: ' , aSendNode asString , ' in: ' , aTMethod asString + , '. Possible variants of the methods exist in: ' , dict associations asString]]. + + "we have to find a class to resolve the selector" + class + ifNotNil: [ + aSendNode + setSelectorForPolymorphism: (class staticallyResolvePolymorphicSelector: aSendNode selector)] + + ! Item was added: + ----- Method: PolymorphicResolver>>staticallyResolvedPolymorphicReceiver:to:in: (in category 'as yet unclassified') ----- + staticallyResolvedPolymorphicReceiver: variableName to: aClass in: theClassWithTheVariable + "We allow a limited amount of polymorphism; if a class chooses, its selectors can be + prefixed with a given string to disambiguate. This hack allows us to use two different + compaction algorithms with the same API at the same time; the selection being done + by a class which holds the flag stating which algorithm is in effect at the current time." + ((staticallyResolvedPolymorphicReceivers ifNil: [staticallyResolvedPolymorphicReceivers := Dictionary new]) + at: theClassWithTheVariable + ifAbsentPut: [Dictionary new]) + at: variableName + put: aClass! Item was added: + ----- Method: PolymorphicResolver>>staticallyResolvedPolymorphicReceivers (in category 'accessing') ----- + staticallyResolvedPolymorphicReceivers + + ^ staticallyResolvedPolymorphicReceivers! Item was added: + ----- Method: PolymorphicResolver>>staticallyResolvedPolymorphicReceivers: (in category 'accessing') ----- + staticallyResolvedPolymorphicReceivers: anObject + + staticallyResolvedPolymorphicReceivers := anObject.! Item was added: + ----- Method: PolymorphicResolver>>transitiveClosureOfMethods:in: (in category 'as yet unclassified') ----- + transitiveClosureOfMethods: aTMethodDictionary in: aClass + + | alreadySeenSelectors toVisit toVisitNext classes mappingSendsToSelectors | + alreadySeenSelectors := Set newFrom: aTMethodDictionary keys. + toVisit := OrderedCollection newFrom: aTMethodDictionary keys. + toVisitNext := OrderedCollection new. + + + mappingSendsToSelectors := Dictionary new. + classes := (aClass withAllSuperclasses copyUpTo: VMClass). + + classes do: [:ea | + ea selectorsAndMethodsDo: [:selector :method | + + method + selectorsDo: [:sel | + mappingSendsToSelectors + at: sel + ifPresent: [:collection | collection add: selector] + ifAbsentPut: [OrderedCollection with: selector]]]]. + + mappingSendsToSelectors. + + [toVisit do: [:ea | + mappingSendsToSelectors at: ea + ifPresent: [:collection | collection + do: [:sender | + (alreadySeenSelectors includes: sender) + ifFalse: [alreadySeenSelectors add: sender. + toVisitNext add: sender]]]]. + toVisit := toVisitNext. + toVisitNext := OrderedCollection new. + + toVisit notEmpty] whileTrue. + + + + "old much slower code. When tested for StackInterpreter there were 3 methods difference. From a first glance I + could not determine why they should be included, but should the future show I simply overlooked something here the + old code for reference + + [toVisit + do: [:each | (SystemNavigation default allCallsOn: each fromBehaviors: (aClass withAllSuperclasses copyUpTo: VMClass) sorted: false) + do: [:method | |selector | + selector := method selector. + (alreadySeenSelectors includes: selector) + ifFalse: [ + selector = #getenv: ifTrue: [self halt]. + alreadySeenSelectors add: selector. + toVisitNext add: selector] ]]. + toVisit := toVisitNext. + toVisitNext := OrderedCollection new. + + toVisit notEmpty] whileTrue." + + ^ alreadySeenSelectors! Item was changed: ----- Method: Spur64BitMemoryManager>>isLilliputianSize: (in category 'free space') ----- isLilliputianSize: chunkBytes "To have a prev pointer, which follows the next pointer, we need at least two slots." + self assert: chunkBytes >= self lilliputianChunkSize. + ^chunkBytes = self lilliputianChunkSize! - self assert: chunkBytes >= (self baseHeaderSize + self allocationUnit). - ^chunkBytes = (self baseHeaderSize + self allocationUnit)! Item was changed: ----- Method: Spur64BitMemoryManager>>setIsMarkedOf:to: (in category 'header access') ----- setIsMarkedOf: objOop to: aBoolean self assert: (self isFreeObject: objOop) not. gc assertSettingGCFlagsIsOk: objOop. + aBoolean ifFalse: [(self isGrey: objOop) ifTrue: [self debugger]]. + self longAt: objOop put: (aBoolean ifTrue: [(self longAt: objOop) bitOr: 1 << self markedBitFullShift] ifFalse: [(self longAt: objOop) bitAnd: (1 << self markedBitFullShift) bitInvert64])! Item was changed: SpurIncrementalMarker subclass: #SpurCountingIncrementalMarker + instanceVariableNames: 'slotsToMark markedSlotCount forwardedCount scannedClasses lastRuntime averageSlotsPerMillisecond lastObjectsSegment' + classVariableNames: 'MinSlotsToMark' - instanceVariableNames: 'mStartTime' - classVariableNames: '' poolDictionaries: '' category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurCountingIncrementalMarker class>>declareCVarsIn: (in category 'as yet unclassified') ----- + declareCVarsIn: aCCodeGenerator + + super declareCVarsIn: aCCodeGenerator. + + aCCodeGenerator + var: 'slotsToMark' declareC: 'sqInt slotsToMark = ', SlotLimitPerPass asString; + var: 'averageSlotsPerMillisecond' declareC: 'sqInt averageSlotsPerMillisecond = 0'; + var: 'lastObjectsSegment' type: #'SpurSegmentInfo *'. + + ! Item was added: + ----- Method: SpurCountingIncrementalMarker class>>initialize (in category 'as yet unclassified') ----- + initialize + + super initialize. + MinSlotsToMark := 1024! Item was changed: ----- Method: SpurCountingIncrementalMarker>>getLifeObjectCountOf: (in category 'segment occupation') ----- getLifeObjectCountOf: segInfo <var: 'segInfo' type: #'SpurSegmentInfo *'> + + self flag: #Todo. "currently unused. Could be used to plan more in alter phases" "hack: use lastFreeObject (only used during snapshot, where GC is already done and we can ignore that it gets changed) to keep track of how much life data is in the segment" ^ self cCode: [segInfo savedSegSize] inSmalltalk: [segInfo savedSegSize ifNil: [0]]! Item was removed: - ----- Method: SpurCountingIncrementalMarker>>incrementalMarkObjects (in category 'marking - incremental') ----- - incrementalMarkObjects - "this method is to be run directly after a scavenge -> we can assume there are ony objects in the now past survivor space" - - <inline: #never> "for profiling" - - "manager runLeakCheckerFor: GCModeIncremental." - - mStartTime := coInterpreter ioUTCMicrosecondsNow. - self initForNewMarkingPassIfNecessary. - - [ | continueMarking | - (manager isEmptyObjStack: manager markStack) - ifTrue: [self pushAllRootsOnMarkStack. - " manager sizeOfObjStack: manager markStack. - did we finish marking?" - (manager isEmptyObjStack: manager markStack) - ifTrue: [self finishMarking. - ^ true]]. - - - "due to a slang limitations we have to assign the result into variable => do not remove!!" - continueMarking := self incrementalMark. - - continueMarking - ifTrue: [true] - ifFalse: [ - coInterpreter cr; print: 'Time until now: '; printNum: coInterpreter ioUTCMicrosecondsNow - mStartTime ; tab; flush. - (coInterpreter ioUTCMicrosecondsNow - mStartTime) < (5000 / 2)]] whileTrue. - - ^ false! Item was changed: ----- Method: SpurCountingIncrementalMarker>>initForNewMarkingPass (in category 'marking-initialization') ----- initForNewMarkingPass + lastObjectsSegment := manager segInfoAt: 0. + super initForNewMarkingPass. 0 to: manager numSegments - 1 do: [:index | | segInfo | segInfo := manager segInfoAt: index. self setUsedMemory: 0 for: segInfo; setLifeObjectCount: 0 for: segInfo]! Item was added: + ----- Method: SpurCountingIncrementalMarker>>initialize (in category 'initialize-release') ----- + initialize + + super initialize. + + slotsToMark := SlotLimitPerPass. + averageSlotsPerMillisecond := 0! Item was added: + ----- Method: SpurCountingIncrementalMarker>>segmentContaining: (in category 'as yet unclassified') ----- + segmentContaining: objOop + + "lets assume the probabilty to scan multiple objects in the same segment is high and measure it later on. + I would assume objects often point to other ones that got allocated at a similar time and located similarly" + + self flag: #Todo. "it is not ok to save pointers to segInfo here. The whole logic here is to inefficient to be honest and should + get an overhaul" + ^ (manager segmentManager is: objOop inSegment: lastObjectsSegment) + ifTrue: [lastObjectsSegment] + ifFalse: [lastObjectsSegment := manager segmentManager segmentContainingObj: objOop]! Item was changed: ----- Method: SpurCountingIncrementalMarker>>setIsMarkedOf: (in category 'header access') ----- setIsMarkedOf: objOop | segmentContainingObject | super setIsMarkedOf: objOop. self flag: #Todo. "we need a more efficient way to get the segment" + segmentContainingObject := self segmentContaining: objOop. - segmentContainingObject := manager segmentManager segmentContainingObj: objOop. self setUsedMemory: (self getUsedMemoryOf: segmentContainingObject) + (manager bytesInBody: objOop) for: segmentContainingObject. + "self - self setLifeObjectCount: (self getLifeObjectCountOf: segmentContainingObject) + 1 + for: segmentContainingObject." - for: segmentContainingObject. + + "we need to know which segment contains pinned objects at the start of the next gc phase for compaction planning " (manager isPinned: objOop) ifTrue: [segmentContainingObject containsPinned: true]! Item was added: + ----- Method: SpurGarbageCollector>>gcIdentifier (in category 'as yet unclassified') ----- + gcIdentifier + + ^ self subclassResponsibility! Item was changed: ----- Method: SpurGenerationScavenger>>processWeakSurvivor: (in category 'weakness and ephemerality') ----- processWeakSurvivor: weakObj "Process a weak survivor on the weakList. Those of its fields which have not survived the scavenge should be nilled, and if any are, the coInterpreter should be informed via fireFinalization:. Answer if the weakObj has any young referents." | weakObjShouldMourn hasYoungReferents numStrongSlots | weakObjShouldMourn := hasYoungReferents := false. "N.B. generateToByDoLimitExpression:negative:on: guards against (unsigned)0 - 1 going +ve" + self assert: (manager isWeak: weakObj). numStrongSlots := manager numFixedSlotsOf: weakObj. 0 to: numStrongSlots - 1 do: [:i| | referent | referent := manager fetchPointer: i ofObject: weakObj. ((manager isNonImmediate: referent) and: [manager isYoungObject: referent]) ifTrue: [hasYoungReferents := true]]. numStrongSlots to: (manager numSlotsOf: weakObj) - 1 do: [:i| | referent | referent := manager fetchPointer: i ofObject: weakObj. "Referent could be forwarded due to scavenging or a become:, don't assume." (manager isNonImmediate: referent) ifTrue: [(manager isForwarded: referent) ifTrue: [referent := manager followForwarded: referent. - "weakObj is either young or already in remembered table; no need to check" - self assert: ((manager isReallyYoungObject: weakObj) - or: [manager isRemembered: weakObj]). manager storePointerUnchecked: i ofObject: weakObj withValue: referent]. + (self isMaybeOldScavengeSurvivor: referent) ifTrue: [(manager isYoungObject: referent) ifTrue: [hasYoungReferents := true]] ifFalse: [(manager gc isOkToClearReference: referent) ifTrue: [ weakObjShouldMourn := true. manager storePointerUnchecked: i ofObject: weakObj withValue: manager nilObject]]]]. + weakObjShouldMourn ifTrue: [coInterpreter fireFinalization: weakObj]. ^hasYoungReferents! Item was changed: ----- Method: SpurIncremental2PhaseGarbageCollector>>doIncrementalCollect (in category 'as yet unclassified') ----- doIncrementalCollect | startTime | phase = InMarkingPhase ifTrue: [ | finishedMarking | marker isCurrentlyMarking ifFalse: [self assert: manager allObjectsUnmarked. manager segmentManager prepareForGlobalSweep]. coInterpreter cr; print: 'start marking '; tab; flush. + startTime := coInterpreter ioUTCMicrosecondsNow. finishedMarking := marker incrementalMarkObjects. + markTime := markTime + (coInterpreter ioUTCMicrosecondsNow - startTime). "self assert: manager validObjectColors." finishedMarking ifTrue: [ "manager allPastSpaceObjectsDo: [:obj | self assert: (manager isWhite: obj)]." "when sweeping the mutator needs to allocate new objects black as we do not have any information about them. We only know if they should get swept after the next marking -> keep them alive for this cycle" self allocatorShouldAllocateBlack: true. compactor setInitialSweepingEntity. self phase: InSweepingPhase. "marking is done and thus all forwarding from the last compaction references are resolved -> we can use the now free segments that were compacted during the last cycle" compactor freePastSegmentsAndSetSegmentToFill. compactor assertNoSegmentBeingCompacted. + "self assert: manager noObjectGrey." - self assert: manager noObjectGrey. coInterpreter cr; print: 'finish marking '; tab; flush. + "startTime := coInterpreter ioUTCMicrosecondsNow. - startTime := coInterpreter ioUTCMicrosecondsNow. manager setCheckForLeaks: GCCheckFreeSpace + GCModeFull; runLeakCheckerFor: GCModeFull excludeUnmarkedObjs: true classIndicesShouldBeValid: true; checkFreeSpace: GCModeFull. manager clearLeakMapAndMapMarkedOrYoungObjects. coInterpreter checkStackIntegrity. + coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush." - coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush. + "0 to: manager numSegments - 1 - 0 to: manager numSegments - 1 do: [:i | | segInfo | segInfo := manager segInfoAt: i. coInterpreter cr; print: 'occupation from marking: '; printNum: (compactor occupationOf: segInfo) * 100; tab; print: '('; printNum: (marker getLifeObjectCountOf: segInfo); print: ' objects -> ' ;printNum: (compactor sizeClaimedIn: segInfo) ; print: ' bytes)' ;flush]. + manager printSegmentOccupationFromMarkedObjects." - manager printSegmentOccupationFromMarkedObjects. + markCount := markCount + 1. + coInterpreter cr; print: 'mark ------> '; printNum: markTime; print: ' '; printNum: manager oldSpaceSize - manager totalFreeOldSpace; tab; flush. + ^ self] ifFalse: [coInterpreter cr; print: 'finish marking pass'; tab; flush. "manager runLeakCheckerFor: GCModeIncremental"]]. phase = InSweepingPhase + ifTrue: [ | finishedSweeping| - ifTrue: [ coInterpreter cr; print: 'start sweeping '; tab; flush. + startTime := coInterpreter ioUTCMicrosecondsNow. + finishedSweeping := compactor incrementalSweepAndCompact. + sweepTime := sweepTime + (coInterpreter ioUTCMicrosecondsNow - startTime). + + finishedSweeping - compactor incrementalSweepAndCompact ifTrue: [ self allocatorShouldAllocateBlack: false. self assert: manager allObjectsWhite. "self assert: manager allObjectsUnmarked." coInterpreter cr; print: 'finish sweeping '; tab; flush. + "startTime := coInterpreter ioUTCMicrosecondsNow. - startTime := coInterpreter ioUTCMicrosecondsNow. manager setCheckForLeaks: GCCheckFreeSpace + GCModeFull; runLeakCheckerFor: GCModeFull; checkFreeSpace: GCModeFull. + coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush." - coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush. + manager setHeapSizeAtPreviousGC. + sweepCount := sweepCount + 1. + coInterpreter cr; print: 'sweep ------> '; printNum: sweepTime; print: ' '; printNum: manager oldSpaceSize - manager totalFreeOldSpace; + print: ' '; printNum: compactor sweptEntities; + print: ' '; printNum: compactor compactedObjects; + print: ' '; printNum: compactor compactor compactedBytes; + print: ' '; printNum: compactor reservedObjects; + tab; flush. + self phase: InMarkingPhase. + coInterpreter postGCAction: GCModeFull. + fullGCWanted := false. ^ self]]! Item was added: + ----- Method: SpurIncremental2PhaseGarbageCollector>>gcIdentifier (in category 'as yet unclassified') ----- + gcIdentifier + + ^ 2! Item was changed: SpurCompactor subclass: #SpurIncrementalCompactingSweeper + instanceVariableNames: 'isCurrentlyWorking currentSegmentsIndex currentsCycleSeenObjectCount currentSegmentsBridge currentObject segmentToFill shouldCompact currentCopyToPointer scStartTime maxObjectsToFree compactedLastCycle sweptEntities compactedObjects reservedObjects compactedBytes' - instanceVariableNames: 'isCurrentlyWorking currentSegmentsIndex currentsCycleSeenObjectCount currentSegmentsBridge currentObject segmentToFill shouldCompact currentCopyToPointer scStartTime maxObjectsToFree' classVariableNames: 'InitialMaxObjectsToFree MaxOccupationForCompaction MinObjectToFree' poolDictionaries: '' category: 'VMMaker-SpurGarbageCollector'! !SpurIncrementalCompactingSweeper commentStamp: 'WoC 1/5/2023 23:21' prior: 0! A SpurIncrementalCompactingSweeper is an incremental sweeper that compacts too. It is a merge of SpurIncrementalSweeper and SpurIncrementalCompactor with slight changes to the algorithm to accomodate to the fact both parts run at the same time. It traverses the heap one time sweeps normal segments, compacts segments that are planned to be compacted (more on that later) and skips the segment that should get filled. The compaction is adapted from: Lazy Pointer Update for Low Heap Compaction Pause Times (Clément Béra; Eliot Miranda; Elisa Gonzalez Boix -> https://doi.org/10.1145/3359619.3359741) The SpurIncrementalCompactingSweeper is designed to run after the SpurCountingIncrementalMarker. The SpurCountingIncrementalMarker will write how many bytes of life data are in segments into the segmentInfo lastFreeObject. As a first step we decide if and when yes which segments should get compacted. We try to compact as many segments as possible, that are under a certain threshold (see MaxOccupationForCompaction what the actual value is), into the segmentToFill (an completetly empty segment we reserve or allocate when no empty segment is available) The interesting entry point for understanding the algorithm is doincrementalSweepAndCompact. We already planned the compaction (read from planCompactionAndReserveSpace) and reserved the segmentToFill (freePastSegmentsAndSetSegmentToFill or findOrAllocateSegmentToFill). We now scan the whole heap. When the current object is in a normal segment we just do a normal sweep. This includes unmarking marked objects and coalescing unmarked objects and free chunks to larger free chunks (the whole succession of free chunks and unmarked objects until the next marked object or end of segment (attention!! only until the end of the segment the first object of this succession is)). Should the current object we see be in the segmentToFill we skip the whole segment. We can safely skip it as it was empty previously (the mutator cannot allocate into the segmentToFill) and we only copy life objects here -> we do not need to do work here as everything here is life. If the current object is in a segment that should be compacted (the current object will then be at the beginning of the segment) we start to compact it into segmentToFill. Free chunks get detached and set to a different class (so other safety mechanism ignore them). Marked objects get unmarked and forwarded to the segmentToFill. Unmarked objects get ignored (we just unremember them). Instance Variables currentCopyToPointer: <Object> currentObject: <Object> currentSegmentsBridge: <Object> currentSegmentsIndex: <Object> currentsCycleSeenObjectCount: <Object> isCurrentlyWorking: <Object> segmentToFill: <Object> shouldCompact: <Object> currentCopyToPointer - xxxxx currentObject - xxxxx currentSegmentsBridge - xxxxx currentSegmentsIndex - xxxxx currentsCycleSeenObjectCount - xxxxx isCurrentlyWorking - xxxxx segmentToFill - xxxxx shouldCompact - xxxxx ! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>canUseAsFreeSpace: (in category 'testing') ----- canUseAsFreeSpace: objOop <inline: true> + ^ (manager isFreeObject: objOop) or: [manager isWhite: objOop]! - ^ (manager isFreeObject: objOop) or: [(manager isMarked: objOop) not]! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>cannotBeCompacted: (in category 'testing') ----- cannotBeCompacted: segInfo ^ (self isSegmentBeingCompacted: segInfo) or: [segInfo containsPinned + or: [(self sizeClaimedIn: segInfo) = 0]]! - or: [manager segmentManager isEmptySegment: segInfo]]! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>cautiousBulkFreeChunkFrom: (in category 'incremental sweeping') ----- cautiousBulkFreeChunkFrom: objOop "The old space entity before objOop is necessarily a marked object. Attempts to free as many bytes from objOop start as possible, looking ahead to free contiguous freechunks / unmarked objects" | bytes start next currentObj | self assert: (self canUseAsFreeSpace: objOop). start := manager startOfObject: objOop. currentObj := objOop. bytes := 0. + [ + sweptEntities := sweptEntities + 1. + bytes := bytes + (manager bytesInBody: currentObj). - [bytes := bytes + (manager bytesInBody: currentObj). (manager isRemembered: currentObj) ifTrue: [self assert: (manager isFreeObject: currentObj) not. scavenger forgetObject: currentObj]. (manager isFreeObject: currentObj) ifTrue: [ "we need to unlink chunks for concurrent sweeping. In the stop the world sweeper we can just reset the freeLists but here we need to keep them around so the mutator can still work between sweeping passes" self flag: #Todo. "we want to optimize for lilliputian chunks!! For now it is ok(ish) but we have to do something about it. At the moment I see 3 possibilities: - have the lilliputian list always sorted (O(n) insert in the worst case!!) - sort the lilliputian part before sweeping (O(n log n) at the start. but everytime before sweeping) - be cheeky and discard the lilliputian list (problem: the mutator has no access to the list + it can insert unsorted chunks (for the duration of sweeping we could let it use a second list and just append it after sweeping)" manager detachFreeObject: currentObj. "self assert: manager totalFreeOldSpace = manager totalFreeListBytes."]. next := manager objectStartingAt: start + bytes. - currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1. self assert: ((manager oop: next isLessThan: manager endOfMemory) or: [next = manager endOfMemory and: [(self canUseAsFreeSpace: next) not]]). "should the next object not be usable as free space (because it is marked) abort the loop. Attention: briges at the end of segments are marked and therefore we leave the loop here. This is important as the newly created free space segment should not be bigger than there still is space left in the current segment" + (self canUseAsFreeSpace: next) and: [coInterpreter ioUTCMicrosecondsNow - scStartTime < 5000]] - (self canUseAsFreeSpace: next) and: [currentsCycleSeenObjectCount < maxObjectsToFree]] whileTrue: [currentObj := next]. ^ manager addFreeChunkWithBytes: bytes at: start! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>compactSegment:freeStart:segIndex: (in category 'incremental compact') ----- compactSegment: segInfo freeStart: initialFreeStart segIndex: segIndex <var: 'segInfo' type: #'SpurSegmentInfo *'> | fillStart | fillStart := initialFreeStart. self deny: segIndex = 0. "Cannot compact seg 0" manager segmentManager allEntitiesInSegment: segInfo exceptTheLastBridgeDo: [:entity | (manager isFreeObject: entity) ifTrue: + [ + reservedObjects := reservedObjects + 1. + manager detachFreeObject: entity. - [manager detachFreeObject: entity. - currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1. "To avoid confusing too much Spur (especially the leak/free checks), we mark the free chunk as a word object." manager set: entity classIndexTo: manager wordSizeClassIndexPun formatTo: manager wordIndexableFormat] ifFalse: [ - (manager isPinned: entity) - ifTrue: [manager debugger]. (manager isMarked: entity) ifTrue: [| bytesToCopy | + + self flag: #Todo. "is it enough to unremember them instead of copying?" "note: we copy even forwarders if they are marked so they cannot get lost" manager makeWhite: entity. + "I really hate that this can happen :( . The marker will keep track of which segments contain pinned objects. + If the pinned object is created during sweeping and compacting, we cannot know about it during planning" - "I really hat that this can happen :( . The marker will keep track of which segments contain pinned objects. - If the pinned object is created during sweeping and compacting, we cannot know about it while working at - our plan we did at the start of sweeping and compacting" (manager isPinned: entity) + ifTrue: [self abortCompactionAt: entity in: segInfo. ^ fillStart]. - ifTrue: [self abortCompactionAt: entity in: segInfo]. bytesToCopy := manager bytesInBody: entity. (self canTolerateObjStartingAt: fillStart sized: bytesToCopy inSegment: segmentToFill) ifFalse: [ self abortCompactionAt: entity in: segInfo. ^ fillStart]. + compactedObjects := compactedObjects + 1. + compactedBytes := compactedBytes + bytesToCopy. + - "let's make copying more expensive. Number is just a guess" - currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 100. self migrate: entity sized: bytesToCopy to: fillStart. fillStart := fillStart + bytesToCopy. self assert: (self oop: fillStart isLessThan: (segmentToFill segLimit - manager bridgeSize))] + ifFalse: [ + sweptEntities := sweptEntities + 1. + self handleUnmarkedEntity: entity]]]. - ifFalse: [self handleUnmarkedEntity: entity]]]. "we want to advance to the next segment from the bridge" currentObject := currentSegmentsBridge. ^ fillStart! Item was added: + ----- Method: SpurIncrementalCompactingSweeper>>compactedBytes (in category 'as yet unclassified') ----- + compactedBytes + + ^ compactedBytes! Item was added: + ----- Method: SpurIncrementalCompactingSweeper>>compactedObjects (in category 'as yet unclassified') ----- + compactedObjects + + ^ compactedObjects! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>computeSegmentsToCompact (in category 'compaction planning') ----- computeSegmentsToCompact "Compute segments to compact: least occupied. Answers true if compaction should be done (at least 1 segment is being compacted and there is a segment to compact into)." | canStillClaim aboutToClaim aboutToClaimSegment atLeastOneSegmentToCompact | <var: 'aboutToClaimSegment' type: #'SpurSegmentInfo *'> atLeastOneSegmentToCompact := false. aboutToClaimSegment := self findNextSegmentToCompact. "Segment to fill is one of the segment compacted last GC. If no segment were compacted last GC, and that there is at least one segment to compact, allocate a new one." aboutToClaimSegment ifNil: [^false]. segmentToFill ifNil: [self findOrAllocateSegmentToFill. segmentToFill ifNil: ["Abort compaction"^false]]. canStillClaim := segmentToFill segSize - manager bridgeSize. [aboutToClaimSegment ifNil: [^atLeastOneSegmentToCompact]. aboutToClaim := self sizeClaimedIn: aboutToClaimSegment. aboutToClaim < canStillClaim ] whileTrue: [self markSegmentAsBeingCompacted: aboutToClaimSegment. coInterpreter cr; print: 'about to compact segment '; printNum: (manager segmentManager indexOfSegment: aboutToClaimSegment); print: ' from: '; printHex: aboutToClaimSegment segStart; print: ' to: '; printHex: aboutToClaimSegment segStart + aboutToClaimSegment segSize ;tab; flush. atLeastOneSegmentToCompact := true. canStillClaim := canStillClaim - aboutToClaim. aboutToClaimSegment := self findNextSegmentToCompact]. ^atLeastOneSegmentToCompact! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>doIncrementalSweep (in category 'incremental sweeping') ----- doIncrementalSweep self assert: (self addressOf: (manager segmentManager segments at: currentSegmentsIndex)) ~= segmentToFill. (self canUseAsFreeSpace: currentObject) ifTrue: [currentObject := self cautiousBulkFreeChunkFrom: currentObject] + ifFalse: [self unmarkCurrentObject. sweptEntities := sweptEntities + 1.]! - ifFalse: [self unmarkCurrentObject]! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>doincrementalSweepAndCompact (in category 'sweep and compact') ----- doincrementalSweepAndCompact "Scan the heap for unmarked objects and free them. Coalescence " self assert: currentObject notNil. currentsCycleSeenObjectCount := 0. [self oop: currentObject isLessThan: manager endOfMemory] whileTrue: [ currentObject = currentSegmentsBridge ifTrue: [self advanceSegment] ifFalse: [self sweepOrCompactFromCurrentObject]. "coInterpreter cr; print: 'Arrived: '; printNum: coInterpreter ioUTCMicrosecondsNow - scStartTime ; tab; print: ' -> '; printNum: currentsCycleSeenObjectCount." + (currentObject ~= currentSegmentsBridge) + ifTrue: [ + coInterpreter ioUTCMicrosecondsNow - scStartTime > 5000 + ifTrue: [^ false]]]. - (currentObject ~= currentSegmentsBridge and: [currentsCycleSeenObjectCount >= maxObjectsToFree]) - ifTrue: [| runTime | - runTime := (coInterpreter ioUTCMicrosecondsNow - scStartTime). - runTime > 5000 - ifTrue: [ - maxObjectsToFree := self calculateNextMaxObjectToFreeBasedOn: runTime. - - coInterpreter cr; - print: 'Time in sweep and compact: '; - printNum: coInterpreter ioUTCMicrosecondsNow - scStartTime ; tab; - print: 'maxObjectsToFree now: '; printNum: maxObjectsToFree; tab; flush. - ^ false] - ifFalse: [ - maxObjectsToFree := self calculateNextMaxObjectToFreeBasedOn: runTime. - currentsCycleSeenObjectCount := 0]]]. + "coInterpreter cr; - coInterpreter cr; print: 'Time in sweep and compact: '; + printNum: coInterpreter ioUTCMicrosecondsNow - scStartTime ; tab; flush." - printNum: coInterpreter ioUTCMicrosecondsNow - scStartTime ; tab; flush. + " manager checkFreeSpace: GCModeIncremental. - manager checkFreeSpace: GCModeIncremental. manager heapMap clearLeakMapAndMapAccessibleObjects. + coInterpreter checkStackIntegrity." - coInterpreter checkStackIntegrity. ^ true! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>finishSweepAndCompact (in category 'sweep and compact') ----- finishSweepAndCompact self assert: manager allObjectsWhite. + compactedLastCycle := shouldCompact. self reset. + + self flag: #Todo. "update time needed for gc"! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>freePastSegmentsAndSetSegmentToFill (in category 'api') ----- freePastSegmentsAndSetSegmentToFill "The first segment being claimed met becomes the segmentToFill. The others are just freed." <var: 'segInfo' type: #'SpurSegmentInfo *'> 0 to: manager numSegments - 1 do: [:i| | segInfo | segInfo := manager segInfoAt: i. (self wasSegmentsCompactionAborted: segInfo) ifTrue: [ | freeUntil chunkBytes | freeUntil := manager startOfObject: (self getEndOfCompaction: segInfo). chunkBytes := freeUntil - segInfo segStart. "maybe we could not even move one object out of the segment. Make sure we do not produce an invalid free chunk" chunkBytes > 0 + ifTrue: ["coInterpreter - ifTrue: [coInterpreter cr; print: 'partially freeing segment from: '; printHex: segInfo segStart; + print: ' to: '; printHex: freeUntil ;tab; flush." - print: ' to: '; printHex: freeUntil ;tab; flush. manager addFreeChunkWithBytes: chunkBytes at: segInfo segStart]. self unmarkSegmentAsBeingCompacted: segInfo]. (self isSegmentBeingCompacted: segInfo) ifTrue: [ | freeChunk chunkBytes | self assert: (manager segmentManager allObjectsAreForwardedInSegment: segInfo includingFreeSpace: false). self assert: (manager noElementOfFreeSpaceIsInSegment: segInfo). + "coInterpreter - coInterpreter cr; print: 'freeing segment from: '; printHex: segInfo segStart; + print: ' to: '; printHex: segInfo segStart + segInfo segSize ;tab; flush." - print: ' to: '; printHex: segInfo segStart + segInfo segSize ;tab; flush. chunkBytes := segInfo segSize - manager bridgeSize. freeChunk := manager addFreeChunkWithBytes: chunkBytes at: segInfo segStart. self unmarkSegmentAsBeingCompacted: segInfo. segmentToFill ifNil: [manager detachFreeObject: freeChunk. segmentToFill := segInfo. + self assertSegmentToFillIsInSegmentsArray]]]. + + manager attemptToShrink! - self assertSegmentToFillIsInSegmentsArray]]]! Item was added: + ----- Method: SpurIncrementalCompactingSweeper>>giveSegmentToFillBackToMemoryManager (in category 'as yet unclassified') ----- + giveSegmentToFillBackToMemoryManager + + "part of gcForSnapshot. only intented to be run after a complete incremental gc cycle is done (just before starting + the next marking pass)" + + segmentToFill ifNil: [^ self]. + + self assertSegmentToFillIsInSegmentsArray. + self assert: (manager isEmptySegment: segmentToFill). + + manager + addFreeChunkWithBytes: segmentToFill segSize - manager bridgeSize + at: segmentToFill segStart. + + "we have compacted into segmentToFill. It is now not empty anymore and we need to look for a new one" + segmentToFill := nil + + ! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>handleUnmarkedEntity: (in category 'compaction planning') ----- handleUnmarkedEntity: entity (manager isRemembered: entity) ifTrue: [self assert: (manager isFreeObject: entity) not. scavenger forgetObject: entity]. - - "To avoid confusing too much Spur (especially the leak/free checks), we don't make the dead object a free chunk, but make it - a non pointer object to avoid the leak checker to try to follow the pointers of the dead object. - Should we abort compacting this segment the object will get kept alife for one gc cycle" - manager set: entity classIndexTo: manager wordSizeClassIndexPun formatTo: manager wordIndexableFormat. currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1.! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>incrementalSweepAndCompact (in category 'api') ----- incrementalSweepAndCompact + <inline: #never> scStartTime := coInterpreter ioUTCMicrosecondsNow. self initIfNecessary. self assertSegmentToFillIsInSegmentsArray. "should in between sweeper calls segments be removed the index would not be correct anymore. Reset it here so we can be sure it is correct" currentSegmentsIndex := manager segmentManager segmentIndexContainingObj: currentObject. "if the bridge between segments was small before and the segment directly after the current one was removed the position of the bridge moved. Update the current position to avoid this case" currentSegmentsBridge := manager segmentManager bridgeAt: currentSegmentsIndex. " so expensive :( self assert: manager validObjectColors." - coInterpreter cr; - print: 'Starting up '; - printNum: coInterpreter ioUTCMicrosecondsNow - scStartTime ; tab. - self doincrementalSweepAndCompact ifTrue: [self finishSweepAndCompact. ^ true]. "do not end on a bridge!! If a segment behind the current one currentObject is removed the size of the bridge can change from 8 bytes to 16 bytes and therefore invalidating currentObject that is now pointing to the overflow header instad of the bridges body. To not hove to implement some finicky update mechanism in the removal of segments just make sure we never reference the bridge before giving back the control to the mutator" self assert: (manager isSegmentBridge: currentObject) not. "skip empty segments. There is no work for us to do + they can be removed. As currentObject is always in the current segment + it would not be valid anymore" - it won't be valid anymore" self assert: (manager segmentManager isEmptySegment: self currentSegment) not. + "coInterpreter cr; print: 'current position: '; printHex: currentObject; tab; flush." - coInterpreter cr; print: 'current position: '; printHex: currentObject; tab; flush. ^ false! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>initIfNecessary (in category 'state initialization') ----- initIfNecessary isCurrentlyWorking ifFalse: [ self initForSweeping. self initForCompaction. + + sweptEntities := compactedObjects := compactedBytes := reservedObjects := 0. isCurrentlyWorking := true]! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>initialize (in category 'initialize-release') ----- initialize isCurrentlyWorking := false. currentSegmentsIndex := 0. currentsCycleSeenObjectCount := 0. currentSegmentsBridge := nil. currentObject := nil. segmentToFill := nil. shouldCompact := false. + compactedLastCycle = false. currentCopyToPointer := nil. maxObjectsToFree := InitialMaxObjectsToFree! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>planCompactionAndReserveSpace (in category 'compaction planning') ----- planCompactionAndReserveSpace + shouldCompact := compactedLastCycle + ifTrue: [coInterpreter cr; print: 'compacted last cycle. resting '; tab; flush.false] + ifFalse: [self computeSegmentsToCompact] - shouldCompact := self computeSegmentsToCompact + + ! Item was added: + ----- Method: SpurIncrementalCompactingSweeper>>reservedObjects (in category 'as yet unclassified') ----- + reservedObjects + + ^ reservedObjects! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>sweepOrCompactFromCurrentObject (in category 'sweep and compact') ----- sweepOrCompactFromCurrentObject + self flag: #Todo. "cache fore segment we already tested. It does not change during this phase" self shouldCompactCurrentSegment ifTrue: [self doIncrementalCompact. "either we finished compacting the segment or we had to abort compaction as the segment to fill cannot take more objects from this segment. We have to continue sweeping. This is done by unmarking the current segment as beeing compacted and making sure the last object we nearly copied before (and we know was alive after marking) is kept alive for sweeping" self assert: ((manager isSegmentBridge: currentObject) or: [(manager isMarked: currentObject) and: [(self isSegmentAtIndexBeingCompacted: currentSegmentsIndex) not]])] ifFalse: [self doIncrementalSweep. currentObject := self nextCurrentObject] ! Item was added: + ----- Method: SpurIncrementalCompactingSweeper>>sweptEntities (in category 'as yet unclassified') ----- + sweptEntities + + ^ sweptEntities! Item was changed: ----- Method: SpurIncrementalCompactingSweeper>>unmarkCurrentObject (in category 'incremental sweeping') ----- unmarkCurrentObject + self unmark: currentObject! - self unmark: currentObject. - currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1! Item was changed: SpurCompactor subclass: #SpurIncrementalCompactor + instanceVariableNames: 'isCompacting segmentToFill shouldCompact currentHeapPointer currentSegmentsStart currentSegmentIndex cStartTime compactedLastCycle compactedObjects compactedBytes reservedObjects' - instanceVariableNames: 'isCompacting segmentToFill shouldCompact currentHeapPointer currentSegment' classVariableNames: 'MaxOccupationForCompaction' poolDictionaries: '' category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurIncrementalCompactor>>abortCompactionAt:in: (in category 'as yet unclassified') ----- + abortCompactionAt: entity in: segInfo + + <var: 'segInfo' type: #'SpurSegmentInfo *'> + "somebody allocated a new object we did not knew about at the moment of planning :( + -> it does not fit anymore and we cannot free the whole segment or the object is pinned. Make sure to + unmark the segment as beeing compacted as it would be completetly freed otherwise!!" + (manager isPinned: entity) + ifTrue: [coInterpreter cr; print: 'segments contains pinned object. '] + ifFalse: [coInterpreter cr; print: 'segments if full. ']. + coInterpreter cr; print: 'Abort compacting of: '; printHex: segInfo segStart ; tab; flush. + + self unmarkSegmentAsBeingCompacted: self currentSegment! Item was added: + ----- Method: SpurIncrementalCompactor>>canTolerateObjStartingAt:sized:inSegment: (in category 'testing') ----- + canTolerateObjStartingAt: address sized: numBytes inSegment: segInfo + "do not copy and object that would overflow the segment or leave only 8 bytes, as the smallest + object size is 16 bytes and we would violate heap parsability (until slim bridges or another hack + mitigating this limitation comes around)" + + <var: 'segInfo' type: #'SpurSegmentInfo *'> + + | bridgeAddress | + bridgeAddress := segInfo segLimit - manager bridgeSize. + ^ (self oop: address + numBytes isLessThan: bridgeAddress) + and: [address + numBytes + 8 ~= bridgeAddress]! Item was changed: ----- Method: SpurIncrementalCompactor>>cannotBeCompacted: (in category 'as yet unclassified') ----- cannotBeCompacted: segInfo + ^ (self isSegmentBeingCompacted: segInfo) + or: [segInfo containsPinned + or: [manager segmentManager isEmptySegment: segInfo]]! - ^ (self isSegmentBeingCompacted: segInfo) or: [segInfo containsPinned or: [manager segmentManager isEmptySegment: segInfo]]! Item was changed: ----- Method: SpurIncrementalCompactor>>compactSegment:freeStart:segIndex: (in category 'incremental compaction') ----- compactSegment: segInfo freeStart: initialFreeStart segIndex: segIndex <var: 'segInfo' type: #'SpurSegmentInfo *'> | fillStart | fillStart := initialFreeStart. self deny: segIndex = 0. "Cannot compact seg 0" manager segmentManager allEntitiesInSegment: segInfo exceptTheLastBridgeDo: [:entity| (manager isFreeObject: entity) ifTrue: + [reservedObjects := reservedObjects + 1. + manager detachFreeObject: entity. - [manager detachFreeObject: entity. "To avoid confusing too much Spur (especially the leak/free checks), we mark the free chunk as a word object." manager set: entity classIndexTo: manager wordSizeClassIndexPun formatTo: manager wordIndexableFormat] ifFalse: ["During the mutator runs new forwarding references can be created. Ignore them as they get resolved with the other forwarders in this segment in the next marking pass" + self flag: #Todo. "if forwarded we still need to unremember" (manager isForwarded: entity) ifFalse: [| bytesToCopy | + + "I really hate that this can happen :( . The marker will keep track of which segments contain pinned objects. + If the pinned object is created during sweeping and compacting, we cannot know about it during planning" + (manager isPinned: entity) + ifTrue: [self abortCompactionAt: entity in: segInfo. ^ fillStart]. + "Copy the object in segmentToFill and replace it by a forwarder." bytesToCopy := manager bytesInBody: entity. + (self canTolerateObjStartingAt: fillStart sized: bytesToCopy inSegment: segmentToFill) + ifFalse: [self abortCompactionAt: entity in: segInfo. + + currentSegmentIndex := currentSegmentIndex + 1. - (self oop: fillStart + bytesToCopy isLessThan: (segmentToFill segLimit - manager bridgeSize)) - ifFalse: ["somebody allocated a new object we did not knew about at the moment of planning :( -> it does not fit anymore and we cannot free the whole segment. Make sure to unmark the segment as beeing compacted as it would be completetly freed otherwise!!" - coInterpreter cr; print: 'segments if full. Abort compacting of: '; printHex: segmentToFill segStart ; tab; flush. - self unmarkSegmentAsBeingCompacted: (manager segInfoAt: currentSegment). - currentSegment := currentSegment + 1. ^ fillStart]. + + compactedObjects := compactedObjects + 1. + compactedBytes := compactedBytes + bytesToCopy. self migrate: entity sized: bytesToCopy to: fillStart. fillStart := fillStart + bytesToCopy. self assert: (self oop: fillStart isLessThan: (segmentToFill segLimit - manager bridgeSize))]]]. + currentSegmentIndex := currentSegmentIndex + 1. - currentSegment := currentSegment + 1. ^ fillStart! Item was added: + ----- Method: SpurIncrementalCompactor>>compactedBytes (in category 'as yet unclassified') ----- + compactedBytes + + ^ compactedBytes! Item was added: + ----- Method: SpurIncrementalCompactor>>compactedObjects (in category 'as yet unclassified') ----- + compactedObjects + + ^ compactedObjects! Item was changed: ----- Method: SpurIncrementalCompactor>>completeCompact (in category 'as yet unclassified') ----- completeCompact | segInfo | self initCompactionIfNecessary. 0 to: manager numSegments - 1 do: [:i | segInfo := manager segInfoAt: i. (self isSegmentBeingCompacted: segInfo) + ifTrue: [currentSegmentIndex := i. - ifTrue: [currentSegment := i. currentHeapPointer := self compactSegment: segInfo freeStart: currentHeapPointer segIndex: i. self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize))]]. self postCompactionAction. self finishCompaction.! Item was added: + ----- Method: SpurIncrementalCompactor>>currentSegment (in category 'as yet unclassified') ----- + currentSegment + + ^ manager segInfoAt: currentSegmentIndex! Item was changed: ----- Method: SpurIncrementalCompactor>>doIncrementalCompact (in category 'incremental compaction') ----- doIncrementalCompact <inline: #never> | segInfo | + currentSegmentIndex to: manager numSegments - 1 do: - currentSegment to: manager numSegments - 1 do: [:i | segInfo := manager segInfoAt: i. (self isSegmentBeingCompacted: segInfo) + ifTrue: [currentSegmentIndex := i. - ifTrue: [currentSegment := i. coInterpreter cr; print: 'Compact from: '; printHex: segInfo segStart; print: ' to: '; printHex: segInfo segStart + segInfo segSize; print: ' into: ' ; printHex: segmentToFill segStart; tab; flush. currentHeapPointer := self compactSegment: segInfo freeStart: currentHeapPointer segIndex: i. self assert: manager totalFreeOldSpace = manager totalFreeListBytes. self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize)). "guarantee heap parsability for the segmentToFill, for example when invoking checkHeapFreeSpaceIntegrityForIncrementalGC where we walk to whole heap and could enter segmentToFill in an invalid state" self occupyRestOfFreeCompactedIntoSegment. coInterpreter cr; print: 'Pointer now: '; printHex: currentHeapPointer; tab; flush. self flag: #Todo. "for now we compact one segment at a time" + ^ currentSegmentIndex = manager numSegments "compact will increment currentSegmentIndex and therefore we cannot compare against numSegments to not skip the last segment" - ^ currentSegment = manager numSegments "compact will increment currentSegment and therefore we cannot compare against numSegments to not skip the last segment" ifTrue: [true] ifFalse: [false]]]. ^ true! Item was added: + ----- Method: SpurIncrementalCompactor>>findCurrentSegmentIndex (in category 'as yet unclassified') ----- + findCurrentSegmentIndex + + 0 to: manager numSegments -1 + do: [:index | | segInfo | + segInfo := manager segInfoAt: index. + ">= to take the next best if the segment the compactor ended in last does not exist anymore" + segInfo segStart >= currentSegmentsStart + ifTrue: [currentSegmentIndex := index. ^ self]]. + + + self flag: #Todo. "find a better way to handle this" + "should never happen, but just to be sure log it." + coInterpreter cr; print: 'Could not reset the currentSegmentIndex. This is a problem!!!!!! '; tab; flush.! Item was changed: ----- Method: SpurIncrementalCompactor>>finishCompaction (in category 'incremental compaction') ----- finishCompaction self resetCompactor! Item was changed: ----- Method: SpurIncrementalCompactor>>freePastSegmentsAndSetSegmentToFill (in category 'api') ----- freePastSegmentsAndSetSegmentToFill "The first segment being claimed met becomes the segmentToFill. The others are just freed." <var: 'segInfo' type: #'SpurSegmentInfo *'> 0 to: manager numSegments - 1 do: [:i| | segInfo | segInfo := manager segInfoAt: i. (self isSegmentBeingCompacted: segInfo) ifTrue: [ | freeChunk chunkBytes | self assert: (manager segmentManager allObjectsAreForwardedInSegment: segInfo includingFreeSpace: false). self assert: (manager noElementOfFreeSpaceIsInSegment: segInfo). coInterpreter cr; print: 'freeing segment from: '; printHex: segInfo segStart; print: ' to: '; printHex: segInfo segStart + segInfo segSize ;tab; flush. chunkBytes := segInfo segSize - manager bridgeSize. freeChunk := manager addFreeChunkWithBytes: chunkBytes at: segInfo segStart. + segmentToFill ifNil: + [segmentToFill := segInfo. + self reserveSegmentToFillWithFirstChunk: freeChunk]]]. + + manager attemptToShrink! - segmentToFill ifNil: - [manager detachFreeObject: freeChunk. - segmentToFill := segInfo]]]! Item was changed: ----- Method: SpurIncrementalCompactor>>incrementalCompact (in category 'incremental compaction') ----- incrementalCompact segmentToFill ifNotNil: [ + self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize))]. - self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize)). - (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize)) - ifFalse: [self cCode: 'raise(SIGINT)']]. self initCompactionIfNecessary. + "because the segments array can shift, which invalidates the segment index, we need to set it correctly" + self findCurrentSegmentIndex. + segmentToFill ifNotNil: [ self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize))]. shouldCompact ifTrue: [ | finishedCompacting | finishedCompacting := self doIncrementalCompact. segmentToFill ifNotNil: [self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize))]. self postCompactionAction. segmentToFill ifNotNil: [self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize))]. finishedCompacting ifTrue: [ self finishCompaction. ^ true]] ifFalse: [self resetCompactor. ^ true "nothing to compact => we are finished"]. + currentSegmentsStart := (manager segInfoAt: currentSegmentIndex) segStart. + ^ false! Item was changed: ----- Method: SpurIncrementalCompactor>>initCompactionIfNecessary (in category 'incremental compaction') ----- initCompactionIfNecessary isCompacting ifFalse: [self assertNoSegmentBeingCompacted. self planCompactionAndReserveSpace. + reservedObjects := 0. + compactedObjects := 0. + compactedBytes := 0. + self assert: manager totalFreeOldSpace = manager totalFreeListBytes. shouldCompact ifTrue: [ coInterpreter cr; print: 'set the current heap pointer'; tab; flush. currentHeapPointer := segmentToFill segStart]. isCompacting := true. + currentSegmentsStart := (manager segInfoAt: 0) segStart]. - self assert: currentSegment = 0]. ! Item was changed: ----- Method: SpurIncrementalCompactor>>initialize (in category 'initialize-release') ----- initialize isCompacting := false. + currentSegmentIndex := 0. - currentSegment := 0. shouldCompact := false. + currentHeapPointer := 0. + compactedLastCycle := false.! - currentHeapPointer := 0! Item was changed: ----- Method: SpurIncrementalCompactor>>migrate:sized:to: (in category 'as yet unclassified') ----- migrate: obj sized: bytesToCopy to: address | copy | self assert: (manager isPinned: obj) not. manager memcpy: address asVoidPointer _: (manager startOfObject: obj) asVoidPointer _: bytesToCopy. copy := manager objectStartingAt: address. (manager isRemembered: copy) ifTrue: + ["replace the pointer in the remembered set instead of leaving it there. It could get hidden inside the free chunk that will get + created after the next marking phase and the sweeper won't be able to find it and make the scavenger forget it." + scavenger remember: copy insteadOf: obj]. - ["copy has the remembered bit set, but is not in the remembered table." - manager setIsRememberedOf: copy to: false. - scavenger remember: copy]. manager forward: obj to: (manager objectStartingAt: address). ^ copy! Item was changed: ----- Method: SpurIncrementalCompactor>>planCompactionAndReserveSpace (in category 'compaction planning') ----- planCompactionAndReserveSpace + shouldCompact := compactedLastCycle + ifTrue: [coInterpreter cr; print: 'compacted last cycle. resting '; tab; flush.false] + ifFalse: [self computeSegmentsToCompact] - shouldCompact := self computeSegmentsToCompact ! Item was changed: ----- Method: SpurIncrementalCompactor>>reserveSegmentToFill (in category 'segment access') ----- reserveSegmentToFill "remove the free space from the freeLists so the mutator cannot allocate in this segment" | freeChunk | self assert: segmentToFill notNil. - self assert: (self segmentIsEmpty: segmentToFill). freeChunk := manager objectStartingAt: segmentToFill segStart. + self reserveSegmentToFillWithFirstChunk: freeChunk! - manager detachFreeObject: freeChunk! Item was added: + ----- Method: SpurIncrementalCompactor>>reserveSegmentToFillWithFirstChunk: (in category 'segment access') ----- + reserveSegmentToFillWithFirstChunk: freeChunk + "remove the free space from the freeLists so the mutator cannot allocate in this segment" + + self assert: segmentToFill notNil. + self assert: (self segmentIsEmpty: segmentToFill). + + + coInterpreter cr; print: 'reserve segment '; printHex: freeChunk; tab; flush. + manager detachFreeObject: freeChunk. + + "avoid confusing spur, especially for leak checks" + manager + set: freeChunk + classIndexTo: manager wordSizeClassIndexPun + formatTo: manager wordIndexableFormat. + + manager setIsMarkedOf: freeChunk to: true! Item was added: + ----- Method: SpurIncrementalCompactor>>reservedObjects (in category 'as yet unclassified') ----- + reservedObjects + + ^ reservedObjects! Item was changed: ----- Method: SpurIncrementalCompactor>>resetCompactor (in category 'as yet unclassified') ----- resetCompactor self setFreeChunkOfCompactedIntoSegment. + compactedLastCycle := shouldCompact. isCompacting := false. shouldCompact := false. currentHeapPointer := 0. + currentSegmentIndex := 0! - currentSegment := 0! Item was changed: SpurGarbageCollector subclass: #SpurIncrementalGarbageCollector + instanceVariableNames: 'phase allAtOnceMarker checkSetGCFlags stopTheWorldGC fullGCWanted phaseCounter gcPauseGoal shouldCollectCounter markTime markCount sweepTime sweepCount compactTime compactCount trigger' - instanceVariableNames: 'phase allAtOnceMarker checkSetGCFlags stopTheWorldGC fullGCWanted phaseCounter' classVariableNames: 'InCompactingPhase InMarkingPhase InSweepingPhase' poolDictionaries: '' category: 'VMMaker-SpurGarbageCollector'! !SpurIncrementalGarbageCollector commentStamp: 'WoC 1/5/2023 21:36' prior: 0! A SpurIncrementalGarbageCollector is a garbage collection algorithm. The GC is a mark and sweep with an additional compaction if certain conditions are fulfilled. This class manages SpurIncrementalMarker and SpurIncrementalSweepAndCompact (which in turn manages SpurIncrementalCompactor and SpurIncrementalSweeper). The 3 classes implementing the GC are therefore SpurIncrementalMarker, SpurIncrementalSweeper and SpurIncrementalCompactor. Instance Variables allAtOnceMarker: <SpurAllAtOnceMarker> checkSetGCFlags: <Bool> phase: <Number (InMarkingPhase|InSweepingPhase|InCompactingPhase)> allAtOnceMarker - an instance of SpurAllAtOnceMarker. We sometimes need parts of the old (stop-the-world) gc algorithm. This is the marking algorithm we can use through static polymorphism checkSetGCFlags - should we check if it ok to set gc flags or not phase - in which phase is the gc algorithm at the moment. Is either InMarkingPhase, InSweepingPhase or InCompactingPhase ! Item was changed: ----- Method: SpurIncrementalGarbageCollector class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator super declareCVarsIn: aCCodeGenerator. aCCodeGenerator var: 'phase' declareC: 'sqInt phase = 0'; + var: 'checkSetGCFlags' declareC: 'sqInt checkSetGCFlags = 1'; + var: 'shouldCollectCounter' declareC: 'sqInt shouldCollectCounter = 0'; + var: 'trigger' declareC: 'sqInt trigger = 0'. + + #(markTime markCount sweepTime sweepCount compactTime compactCount) + do: [:var | aCCodeGenerator var: var declareC: 'sqInt ' , var , ' = 0'.]. - var: 'checkSetGCFlags' declareC: 'sqInt checkSetGCFlags = 1'. aCCodeGenerator staticallyResolvedPolymorphicReceiver: 'allAtOnceMarker' to: SpurAllAtOnceMarker in: self; staticallyResolvedPolymorphicReceiver: 'stopTheWorldGC' to: SpurStopTheWorldGarbageCollector in: self. SpurMemoryManager gcClass = self ifTrue: [ self declareRecursivePolymorphismMappingForIncrementalClasses: aCCodeGenerator. "just important when doiing incremental compaction, therefore doin it here" aCCodeGenerator forRecursivePolymorphismResolve: SpurAllAtOnceMarker as: SpurStopTheWorldGarbageCollector; forRecursivePolymorphismResolve: SpurPlanningCompactor as: SpurStopTheWorldGarbageCollector]. ! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>assertSettingGCFlagsIsOk: (in category 'as yet unclassified') ----- assertSettingGCFlagsIsOk: objOop + "checkSetGCFlags ifFalse: [^ self]." - checkSetGCFlags ifFalse: [^ self]. "do not color young objects. They have an extra state we do not want to change" + "self assert: (manager isOldObject: objOop). - self assert: (manager isOldObject: objOop). (manager isOldObject: objOop) + ifFalse: [self cCode: 'raise(SIGINT)']." - ifFalse: [self cCode: 'raise(SIGINT)']. "while sweeping: do not color objects behind the currently point the sweeper is at. This would infer with the next marking pass" + "self assert: (self allocatorShouldAllocateBlack not or: [self inSweepingAheadOfSweepersPosition: objOop]). - self assert: (self allocatorShouldAllocateBlack not or: [self inSweepingAheadOfSweepersPosition: objOop]). (self allocatorShouldAllocateBlack not or: [self inSweepingAheadOfSweepersPosition: objOop]) + ifFalse: [self cCode: 'raise(SIGINT)']"! - ifFalse: [self cCode: 'raise(SIGINT)']! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>doIncrementalCollect (in category 'as yet unclassified') ----- doIncrementalCollect | startTime | phase = InMarkingPhase ifTrue: [ | finishedMarking | marker isCurrentlyMarking + ifFalse: [self assert: manager allObjectsUnmarked. + markCount := markCount + 1.]. - ifFalse: [self assert: manager allObjectsUnmarked]. coInterpreter cr; print: 'start marking '; printNum: (phaseCounter := phaseCounter + 1); tab; flush. + startTime := coInterpreter ioUTCMicrosecondsNow. finishedMarking := marker incrementalMarkObjects. + markTime := markTime + (coInterpreter ioUTCMicrosecondsNow - startTime). "self assert: manager validObjectColors." finishedMarking ifTrue: [ + "manager allPastSpaceObjectsDo: [:obj | self assert: (manager isWhite: obj)]." - manager allPastSpaceObjectsDo: [:obj | self assert: (manager isWhite: obj)]. "when sweeping the mutator needs to allocate new objects black as we do not have any information about them. We only know if they should get swept after the next marking -> keep them alive for this cycle" self allocatorShouldAllocateBlack: true. compactor setInitialSweepingEntity. self phase: InSweepingPhase. "marking is done and thus all forwarding from the last compaction references are resolved -> we can use the now free segments that were compacted during the last cycle" compactor freePastSegmentsAndSetSegmentToFill. manager segmentManager prepareForGlobalSweep. self assert: manager noObjectGrey. coInterpreter cr; print: 'finish marking '; tab; flush. + "startTime := coInterpreter ioUTCMicrosecondsNow. - startTime := coInterpreter ioUTCMicrosecondsNow. manager setCheckForLeaks: GCCheckFreeSpace + GCModeFull; runLeakCheckerFor: GCModeFull excludeUnmarkedObjs: true classIndicesShouldBeValid: true; checkFreeSpace: GCModeFull. + coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush." + markCount := markCount + 1. - coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush. - + coInterpreter cr; print: 'mark ------> '; printNum: markTime; print: ' '; printNum: manager oldSpaceSize - manager totalFreeOldSpace; tab; flush. + ^ self] ifFalse: [coInterpreter cr; print: 'finish marking pass'; tab; flush. manager runLeakCheckerFor: GCModeIncremental]]. phase = InSweepingPhase + ifTrue: [ | finishedSweeping | - ifTrue: [ coInterpreter cr; print: 'start sweeping '; tab; flush. + + startTime := coInterpreter ioUTCMicrosecondsNow. + finishedSweeping := compactor incrementalSweep. + sweepTime := sweepTime + (coInterpreter ioUTCMicrosecondsNow - startTime). + + self flag: #Todo. "if not segmentToFill is reserved do so here first before attemp to shrink" + manager attemptToShrink. + + finishedSweeping - compactor incrementalSweep ifTrue: [ self allocatorShouldAllocateBlack: false. + "manager allOldSpaceObjectsDo: [:ea | self assert: (manager isWhite: ea) ]." - manager allOldSpaceObjectsDo: [:ea | self assert: (manager isWhite: ea) ]. "self assert: manager allObjectsUnmarked." coInterpreter cr; print: 'finish sweeping '; tab; flush. + "startTime := coInterpreter ioUTCMicrosecondsNow. - startTime := coInterpreter ioUTCMicrosecondsNow. manager setCheckForLeaks: GCCheckFreeSpace + GCModeFull; runLeakCheckerFor: GCModeFull; checkFreeSpace: GCModeFull. coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush. + compactor assertNoSegmentBeingCompacted." + sweepCount := sweepCount + 1. + coInterpreter cr; print: 'sweep ------> '; printNum: sweepTime; print: ' '; printNum: manager oldSpaceSize - manager totalFreeOldSpace; + print: ' '; printNum: compactor sweeper sweptEntities; tab; flush. - compactor assertNoSegmentBeingCompacted. self phase: InCompactingPhase. ^ self]]. phase = InCompactingPhase + ifTrue: [ | compactionFinished | - ifTrue: [ "self cCode: 'raise(SIGINT)'." coInterpreter cr; print: 'start compacting '; tab; flush. + "compactor isCurrentlyCompacting + ifFalse: [manager printFreeSpaceStatistics]." + + startTime := coInterpreter ioUTCMicrosecondsNow. + compactionFinished := compactor incrementalCompact. + compactTime := compactTime + (coInterpreter ioUTCMicrosecondsNow - startTime). + + compactionFinished - compactor isCurrentlyCompacting - ifFalse: [manager printFreeSpaceStatistics]. - compactor incrementalCompact ifTrue: [ coInterpreter cr; print: 'finish compacting '; tab; flush. + "startTime := coInterpreter ioUTCMicrosecondsNow. - startTime := coInterpreter ioUTCMicrosecondsNow. manager setCheckForLeaks: GCCheckFreeSpace + GCModeFull; runLeakCheckerFor: GCModeFull; checkFreeSpace: GCModeFull. + coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush." - coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush. self phase: InMarkingPhase. + manager attemptToShrink. + coInterpreter postGCAction: GCModeFull. + manager setHeapSizeAtPreviousGC. + + compactCount := compactCount + 1. + coInterpreter cr; print: 'compact ------> '; printNum: compactTime; print: ' '; printNum: manager oldSpaceSize - manager totalFreeOldSpace; + print: ' '; printNum: compactor compactor compactedObjects; + print: ' '; printNum: compactor compactor compactedBytes; + print: ' '; printNum: compactor compactor reservedObjects; + tab; flush. + fullGCWanted := false. ^ self]]! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>doScavenge: (in category 'scavenge') ----- doScavenge: tenuringCriterion "The inner shell for scavenge, abstrascted out so globalGarbageCollect can use it." <inline: false> + + | start | + start := coInterpreter ioUTCMicrosecondsNow. manager doAllocationAccountingForScavenge. manager gcPhaseInProgress: ScavengeInProgress. manager pastSpaceStart: (scavenger scavenge: tenuringCriterion). self assert: (self oop: manager pastSpaceStart isGreaterThanOrEqualTo: scavenger pastSpace start andLessThanOrEqualTo: scavenger pastSpace limit). manager freeStart: scavenger eden start. manager gcPhaseInProgress: 0. manager resetAllocationAccountingAfterGC. + coInterpreter cr; print: 'scavenge time: '; printNum: coInterpreter ioUTCMicrosecondsNow - start; tab; flush. + manager statGCEndUsecs: coInterpreter ioUTCMicrosecondsNow. + manager statSGCDeltaUsecs: manager statGCEndUsecs - manager gcStartUsecs. + (fullGCWanted or: [self numSegmentsAboutToBeFreed > 0]) + ifTrue: [ + shouldCollectCounter = 0 + ifTrue: [self incrementalCollect]. + shouldCollectCounter := (shouldCollectCounter + 1) \\ 5] - ifTrue: [self incrementalCollect] ! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>fullGC (in category 'global') ----- fullGC "We need to be able to make a full GC, e.g. when we save the image. Use the made progress and finish the collection" <returnTypeC: #usqLong> <inline: #never> "for profiling" "incredible hacky solution. Will later on be replaced with the old collection, but for now use this to keep the state transitions consistent" self assert: manager validObjStacks. coInterpreter cr; print: 'start fullGC '; tab; flush. coInterpreter setGCMode: GCModeNewSpace. self doScavengeWithoutIncrementalCollect: MarkOnTenure. coInterpreter setGCMode: GCModeIncremental. phase = InMarkingPhase ifTrue: [ "end marking" [phase = InMarkingPhase] whileTrue: [self doIncrementalCollect]]. "end this collection cycle" [phase ~= InMarkingPhase] whileTrue: [self doIncrementalCollect]. - - "resolve forwarders in young space" - coInterpreter setGCMode: GCModeNewSpace. - self doScavengeWithoutIncrementalCollect: MarkOnTenure. - - coInterpreter setGCMode: GCModeIncremental. - - "mark completely" - [phase = InMarkingPhase] - whileTrue: [self doIncrementalCollect]. - "do rest of collection" - [phase ~= InMarkingPhase] - whileTrue: [self doIncrementalCollect]. manager setHeapSizeAtPreviousGC. coInterpreter cr; print: 'end fullGC '; tab; flush. ^(manager freeLists at: 0) ~= 0 ifTrue: [manager bytesInBody: manager findLargestFreeChunk] ifFalse: [0]! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>gcCounters (in category 'as yet unclassified') ----- + gcCounters + + | result | + result := manager instantiateClass: manager classArray indexableSize: 6. + + manager storePointerUnchecked: 0 ofObject: result withValue: (manager integerObjectOf: markTime). + manager storePointerUnchecked: 1 ofObject: result withValue: (manager integerObjectOf: markCount). + manager storePointerUnchecked: 2 ofObject: result withValue: (manager integerObjectOf: sweepTime). + manager storePointerUnchecked: 3 ofObject: result withValue: (manager integerObjectOf: sweepCount). + manager storePointerUnchecked: 4 ofObject: result withValue: (manager integerObjectOf: compactTime). + manager storePointerUnchecked: 5 ofObject: result withValue: (manager integerObjectOf: compactCount). + + manager beRootIfOld: result. + + ^ result! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>gcCounters: (in category 'as yet unclassified') ----- + gcCounters: result + + manager storePointerUnchecked: 0 ofObject: result withValue: (manager integerObjectOf: markTime). + manager storePointerUnchecked: 1 ofObject: result withValue: (manager integerObjectOf: markCount). + manager storePointerUnchecked: 2 ofObject: result withValue: (manager integerObjectOf: sweepTime). + manager storePointerUnchecked: 3 ofObject: result withValue: (manager integerObjectOf: sweepCount). + manager storePointerUnchecked: 4 ofObject: result withValue: (manager integerObjectOf: compactTime). + manager storePointerUnchecked: 5 ofObject: result withValue: (manager integerObjectOf: compactCount). + + manager beRootIfOld: result. + + ^ result! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>gcForSnapshot (in category 'as yet unclassified') ----- gcForSnapshot self finishGCPass. coInterpreter cr; print: 'finished incremental gc pass'; tab; flush. + compactor giveSegmentToFillBackToMemoryManager. + stopTheWorldGC fullGC. coInterpreter cr; print: 'finished stop the world gc'; tab; flush. ! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>gcIdentifier (in category 'as yet unclassified') ----- + gcIdentifier + + ^ 1! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>incrementalCollect (in category 'global') ----- incrementalCollect | startTime | self flag: #Todo. "where to put this?" manager statScavenges = 0 ifTrue: [manager makeAllObjectsWhite.]. startTime := coInterpreter ioUTCMicrosecondsNow. + manager gcStartUsecs: startTime. + self doIncrementalCollect. + manager statGCEndUsecs: coInterpreter ioUTCMicrosecondsNow. + manager updateFullGCStats. + coInterpreter cr; print: 'time: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush. self assert: manager validObjStacks.! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>initialize (in category 'initialize-release') ----- initialize super initialize. checkSetGCFlags := true. + phase := InMarkingPhase. + phaseCounter := 0. + - phase := InMarkingPhase. phaseCounter := 0. fullGCWanted := false. + gcPauseGoal := 5000. + shouldCollectCounter := 0. + markTime := 0. + markCount := 0. + sweepTime := 0. + sweepCount := 0. + compactTime := 0. + compactCount := 0. + allAtOnceMarker := SpurAllAtOnceMarker new. stopTheWorldGC := SpurStopTheWorldGarbageCollector new. stopTheWorldGC marker: allAtOnceMarker. stopTheWorldGC compactor: SpurPlanningCompactor new! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>maybeModifyForwarder: (in category 'object creation barriers') ----- maybeModifyForwarder: objOop + + self flag: #Todo. "probably obsolete, since we now check if an object is white in the sweeper before freeing it, instead of if it is marked. " "mark forwarders so they do not get garbage collected before they can get resolved. 1. Does only apply to marking because only in this phase we can overlook forwarding references to be resolved (e.g. when the mutator runs after the first marking pass and an object that is referenced by at least one already black object gets a forwarded -> the pointer of the black object won't get updated in this marking pass and during sweeping the forwarding pointer will get removed). 2. Does not apply to sweeping or compacting because the forwarder is set on the header of the original object, which already includes the correcty set mark bit" self assert: (manager isForwarded: objOop). ((manager isOldObject: objOop) and: [marker isCurrentlyMarking]) ifTrue: [marker setIsMarkedOf: objOop. "make sure to grey the forwarder. Maybe the object was pushed on the marking stack before and made grey. Although I am not sure that really present an error, as the object should be collected in the next gc cycle and nobody tries to mark from a forwarder which could cause objects being lost. For now lets preserver the invariant that the heap is completely unmarked and ungrey after sweeping (and sweeping does not unset grey bits" manager setIsGreyOf: objOop to: false]! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>maybeModifyGCFlagsOf: (in category 'object creation barriers') ----- maybeModifyGCFlagsOf: objOop + "when allocating a new object behind the current sweeping high mark it should be allocated black so it does not get garbage - "when allocating a new object behind the current sweeping hight mark it should be allocated black so it does not get garbage collected although we do not know if this is correct (but to know this we would need to mark again and that is expensive + the object was allocated in old space therefore lets assume we want to keep it around (black allocation))" <inline: true> ((manager isOldObject: objOop) and: [self inSweepingAheadOfSweepersPosition: objOop]) ifTrue: [manager setIsMarkedOf: objOop to: true]! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>scavengingGCTenuringIf: (in category 'scavenge') ----- scavengingGCTenuringIf: tenuringCriterion "Run the scavenger." <inline: false> self assert: manager remapBufferCount = 0. (self asserta: scavenger eden limit - manager freeStart > coInterpreter interpreterAllocationReserveBytes) ifFalse: [coInterpreter tab; printNum: scavenger eden limit - manager freeStart; space; printNum: coInterpreter interpreterAllocationReserveBytes; space; printNum: coInterpreter interpreterAllocationReserveBytes - (scavenger eden limit - manager freeStart); cr]. manager checkMemoryMap. + "manager checkFreeSpace: GCModeNewSpace. + manager runLeakCheckerFor: GCModeNewSpace." - manager checkFreeSpace: GCModeNewSpace. - manager runLeakCheckerFor: GCModeNewSpace. coInterpreter preGCAction: GCModeNewSpace; "would prefer this to be in mapInterpreterOops, but compatibility with ObjectMemory dictates it goes here." flushMethodCacheFrom: manager newSpaceStart to: manager oldSpaceStart. manager needGCFlag: false. manager gcStartUsecs: coInterpreter ioUTCMicrosecondsNow. self doScavenge: tenuringCriterion. manager statScavenges: manager statScavenges + 1. + - manager statGCEndUsecs: coInterpreter ioUTCMicrosecondsNow. - manager statSGCDeltaUsecs: manager statGCEndUsecs - manager gcStartUsecs. manager statScavengeGCUsecs: manager statScavengeGCUsecs + manager statSGCDeltaUsecs. manager statRootTableCount: scavenger rememberedSetSize. scavenger logScavenge. coInterpreter postGCAction: GCModeNewSpace. + "manager runLeakCheckerFor: GCModeNewSpace. + manager checkFreeSpace: GCModeNewSpace"! - manager runLeakCheckerFor: GCModeNewSpace. - manager checkFreeSpace: GCModeNewSpace! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>sufficientSpaceAfterGC: (in category 'as yet unclassified') ----- sufficientSpaceAfterGC: numBytes | heapSizePostGC | self assert: numBytes = 0. self scavengingGCTenuringIf: TenureByAge. heapSizePostGC := manager segmentManager totalOldSpaceCapacity - manager totalFreeOldSpace. (heapSizePostGC - manager heapSizeAtPreviousGC) asFloat / manager heapSizeAtPreviousGC >= manager heapGrowthToSizeGCRatio ifTrue: [fullGCWanted := true] "fullGC will attempt to shrink" ifFalse: "Also attempt to shrink if there is plenty of free space and no need to GC" [manager totalFreeOldSpace > (manager shrinkThreshold * 2) ifTrue: [manager attemptToShrink. ^true]]. self flag: #Todo. "we probably want here something more sophisticated, like tak into account how many objects survived tenuring in the near past and how much work is still to be done until marking is finished and the segments get freed. Until then just assume the compacted segments get freed soon enough" + ["self numSegmentsAboutToBeFreed = 0 ""lets wait until we get more space" + "and: ["manager totalFreeOldSpace < manager growHeadroom + and: [(manager growOldSpaceByAtLeast: 0) notNil]] whileTrue: - [self numSegmentsAboutToBeFreed = 0 "lets wait until we get more space" - and: [manager totalFreeOldSpace < manager growHeadroom - and: [(manager growOldSpaceByAtLeast: 0) notNil]]] whileTrue: [manager totalFreeOldSpace >= manager growHeadroom ifTrue: [^true]]. manager lowSpaceThreshold > manager totalFreeOldSpace ifTrue: "space is low" [manager lowSpaceThreshold: 0. "avoid signalling low space twice" ^false]. ^true! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>writeBarrierFor:at:with: (in category 'barrier') ----- writeBarrierFor: anObject at: index with: value + "combination of the usual generational barrier (see SpurStopTheWorldGarbageCollector>>writeBarrierFor:at:with:) + and a dijkstra style write barrier" - "a dijkstra style write barrier with the addition of the generation check - objects that are not able to contain pointers are ignored too, as the write barries - should ensure we lose no references and this objects do not hold any of them" <inline: true> + (manager isOldObject: anObject) ifTrue: "most stores into young objects" + [(manager isYoung: value) + ifTrue: [manager possibleRootStoreInto: anObject] + ifFalse: [ + "don't make the check for the phase using the phase variable of the GC. Phase will indicate marking before + the next GC cycle even started. The marker knows exactly if marking already started" + (marker isCurrentlyMarking and: [manager isMarked: anObject]) + ifTrue: [trigger := trigger + 1. marker markAndShouldScan: value]]]! - self flag: #Todo. "we probably want the oldObject check to be the first one as it is only a pointer comparison and no dereferencing is needed" - - "((manager isImmediate: value) not and: [(manager isPureBitsNonImm: value)]) - ifTrue: [coInterpreter cr; print: 'saw: '; printHexnp: value; tab; flush]." - - self flag: #Todo. "do I need the immediate check?" - (self isMarking and: [(manager isImmediate: value) not and: [(manager isOldObject: anObject) and: [(manager isOldObject: value) and: [manager isMarked: anObject]]]]) - ifTrue: [marker markAndShouldScan: value]! Item was changed: SpurMarker subclass: #SpurIncrementalMarker + instanceVariableNames: 'isCurrentlyMarking mStartTime classBitTable' + classVariableNames: 'ClassBitTableSize SlotLimitPerPass' - instanceVariableNames: 'isCurrentlyMarking' - classVariableNames: 'SlotLimitPerPass' poolDictionaries: '' category: 'VMMaker-SpurGarbageCollector'! !SpurIncrementalMarker commentStamp: 'eem 3/16/2023 10:19' prior: 0! Marker for the SpurIncrementalGarbageCollector. It mark objects in old space (and only in old space!!) incrementally, in batches. Roots are: - Stack references - hidden objects - extra objects - (surviving) young space objects Instance Variables isCurrentlyMarking: <Boolean> isCurrentlyMarking - true if in the mark phase! Item was added: + ----- Method: SpurIncrementalMarker class>>declareCVarsIn: (in category 'as yet unclassified') ----- + declareCVarsIn: aCCodeGenerator + + super declareCVarsIn: aCCodeGenerator. + + aCCodeGenerator + var: #classBitTable + type: 'long long' + sizeString: ClassBitTableSize asString + array: {0}! Item was changed: ----- Method: SpurIncrementalMarker class>>initialize (in category 'as yet unclassified') ----- initialize "experimental value. needs some measurements" + SlotLimitPerPass := 256 * 1024 . + ClassBitTableSize := 256! - SlotLimitPerPass := 256 * 1024 ! Item was added: + ----- Method: SpurIncrementalMarker>>clearClassBitTable (in category 'as yet unclassified') ----- + clearClassBitTable + + self flag: #Todo. "I should probably use a CArray for the smalltalk version" + + self + cCode: [self memset: classBitTable _: 0 _: ClassBitTableSize * 8] + inSmalltalk: [classBitTable := (1 to: 256) collect: [:i | 0]] + ! Item was changed: ----- Method: SpurIncrementalMarker>>finishMarking (in category 'as yet unclassified') ----- finishMarking "marks the structures needed during GC" <inline: #never> "lets assume there are not too many for now" self markWeaklingsAndMarkAndFireEphemerons. [(manager isEmptyObjStack: manager markStack) not] whileTrue: [self incrementalMark]. + + + self flag: #Todo. "now that all reachable objects got marked we could prune the rememberd set here of + unmarked objects" self assert: (manager isEmptyObjStack: manager markStack). "self assert: self allReferencedClassesAreMarked." + "self allReferencedClassesAreMarked not + ifTrue: [self cCode: 'raise(SIGINT)']." + manager expungeDuplicateAndUnmarkedClasses: true ignoringClassesInYoungSpace: true. - self allReferencedClassesAreMarked not - ifTrue: [self cCode: 'raise(SIGINT)']. - manager expungeDuplicateAndUnmarkedClasses: true ignoringClassesInYoungSpace: true. - - "Young space weaklings are not included in the weak set here. If weaklings from young space contain references to old space and the object behind it gets freed during sweeping a scavenge can try to access such an object. Therefore collect all young space weaklings here and nil their references (do it in the end to not include not existing weak objects from previous marking passes" self collectWeaklingsFromYoungSpaceInWeakSet. manager nilUnmarkedWeaklingSlotsExcludingYoungObjects: true. self assert: (manager isEmptyObjStack: manager markStack). isCurrentlyMarking := false. marking := false! Item was changed: ----- Method: SpurIncrementalMarker>>incrementalMark (in category 'marking - incremental') ----- incrementalMark "does one marking cycle. Breaks after a certain amount of slots is marked and the last object, that amount is crossed in, is completely scanned" + + <inline: #never> "for profiling" | currentObj slotsLeft | "manager objStack: manager markStack do: [:index :page | Transcript showln: (manager fetchPointer: index ofObject: page)]. manager sizeOfObjStack: manager markStack" currentObj := manager popObjStack: manager markStack. "skip young objects. They get already scanned as they are part of the roots" + [(currentObj notNil) and: [manager isYoung: currentObj]] + whileTrue: [currentObj := manager popObjStack: manager markStack]. - [(currentObj notNil) and: [(manager isNonImmediate: currentObj) and: [manager isYoung: currentObj]]] - whileTrue: [(manager isInClassTable: currentObj) ifTrue: [self setIsMarkedOf: currentObj ]. - currentObj := manager popObjStack: manager markStack]. currentObj ifNil: [^ true]. "there is nothing more on the stack and we are done" + "arbitrary number. We probably should take a number which correlates with the current allocation behaviour, so we can guarantee + marking finished (although this did worked just fine for me until now)" + slotsLeft := 1024. - slotsLeft := SlotLimitPerPass. [ | slotNumber slotsToVisit startIndex | "after passing the limit we push the current index on the stack. Is the currentObj only an index? " (manager isImmediate: currentObj) ifTrue: [startIndex := manager integerValueOf: currentObj. currentObj := manager popObjStack: manager markStack.] ifFalse: [startIndex := 0. self assert: (manager isFreeObject: currentObj) not. (manager isForwarded: currentObj) ifTrue: [currentObj := manager followForwarded: currentObj]. - self flag: #Todo. "young objects can fall out of a forwarder. Do not follow them" - self assert: (manager isYoung: currentObj) not. + self flag: #Todo. "unify isYoung with shouldScan: later on. " (manager isYoung: currentObj) ifTrue: ["trick to skip young object" startIndex := manager numStrongSlotsOfInephemeral: currentObj] ifFalse: [self markAndTraceClassOf: currentObj. "eager color the object black. Either it will get scanned completely and the color is correct or we have at least scanned some of the slots. In the second case the mutator could modify one of the slots of the object that already were scanned and we would could lose this object. Therefore color the object early to trigger the write barrier on writes. There will be some overhead (trigger the barrier always although only the already scanned slots are technically black) but it seems we need to do this for correctness" + self blackenObject: currentObj]. + + (self shouldScan: currentObj) not + ifTrue: [startIndex := manager numStrongSlotsOfInephemeral: currentObj]]. - self blackenObject: currentObj]]. slotNumber := manager numStrongSlotsOfInephemeral: currentObj. slotsToVisit := slotNumber - startIndex. slotsLeft - slotsToVisit < 0 + ifTrue: [ - ifTrue: [ | countThatCanBeVisited | - countThatCanBeVisited := slotsToVisit - slotsLeft. self markFrom: startIndex + nSlots: slotsLeft - nSlots: countThatCanBeVisited of: currentObj. "If we need to abort earlier we push the index and the currently scanned object on the marking stack. Otherwise it is not possible for immediates to be on the stack (they have no fields to be scanned) -> we can use the immediated to detect this pattern" (manager topOfObjStack: manager markStack) ~= currentObj ifTrue: [manager push: currentObj onObjStack: manager markStack]. manager + push: (manager integerObjectOf: startIndex + slotsLeft) - push: (manager integerObjectOf: startIndex + countThatCanBeVisited) onObjStack: manager markStack. "we need to abort early to not run into some extreme corner cases (giant objects) that would explode our mark time assumptions" + coInterpreter ioUTCMicrosecondsNow - mStartTime > 5000 + ifTrue: [^ false] + ifFalse: [slotsLeft := 1024]] - ^ false] ifFalse: ["we can mark all" slotsLeft := slotsLeft - slotsToVisit. self markFrom: startIndex nSlots: slotsToVisit of: currentObj]. currentObj := manager popObjStack: manager markStack. + [(currentObj notNil) and: [manager isYoung: currentObj]] + whileTrue: [currentObj := manager popObjStack: manager markStack]. - [(currentObj notNil) and: [(manager isNonImmediate: currentObj) and: [manager isYoung: currentObj]]] - whileTrue: [(manager isInClassTable: currentObj) ifTrue: [self setIsMarkedOf: currentObj]. - currentObj := manager popObjStack: manager markStack]. "repeat while there still are objects" currentObj notNil] whileTrue. ^ true! Item was changed: ----- Method: SpurIncrementalMarker>>incrementalMarkObjects (in category 'marking - incremental') ----- incrementalMarkObjects "this method is to be run directly after a scavenge -> we can assume there are ony objects in the now past survivor space" <inline: #never> "for profiling" "manager runLeakCheckerFor: GCModeIncremental." + mStartTime := coInterpreter ioUTCMicrosecondsNow. + self initForNewMarkingPassIfNecessary. [ | continueMarking | (manager isEmptyObjStack: manager markStack) ifTrue: [self pushAllRootsOnMarkStack. " manager sizeOfObjStack: manager markStack. did we finish marking?" (manager isEmptyObjStack: manager markStack) ifTrue: [self finishMarking. ^ true]]. "due to a slang limitations we have to assign the result into variable => do not remove!!" continueMarking := self incrementalMark. continueMarking] whileTrue. ^ false ! Item was changed: ----- Method: SpurIncrementalMarker>>initForNewMarkingPass (in category 'marking-initialization') ----- initForNewMarkingPass manager initializeMarkStack. manager initializeWeaklingStack. manager initializeEphemeronStack. + self clearClassBitTable. + "This must come first to enable stack page reclamation. It clears the trace flags on stack pages and so must precede any marking. Otherwise it will clear the trace flags of reached pages." coInterpreter initStackPageGC. self markHelperStructures. isCurrentlyMarking := true. marking := true. self pushInternalStructuresOnMarkStack ! Item was changed: ----- Method: SpurIncrementalMarker>>initialize (in category 'initialize-release') ----- initialize super initialize. isCurrentlyMarking := false. + marking := false. + self flag: #Todo. "use CArray" + classBitTable := OrderedCollection new! - marking := false! Item was changed: ----- Method: SpurIncrementalMarker>>markAndScan: (in category 'marking - incremental') ----- markAndScan: objOop "marks the object (grey or black as neccessary) and returns if the object should be scanned This is simply the non-inlined version of markAndShouldScan:" <inline: #never> + ((manager isNonImmediate: objOop) and: [(self isGrey: objOop) and: [(self is: objOop onObjStack: manager markStack) not]]) ifTrue: [manager debugger]. ^self markAndShouldScan: objOop! Item was changed: ----- Method: SpurIncrementalMarker>>markAndShouldScan: (in category 'marking - incremental') ----- markAndShouldScan: objOop "marks the object (grey or black as neccessary) and returns if the object should be scanned Objects that get handled later on get marked as black, as they are practically a leaf in the object tree (we scan them later on, so we cannot lose objects and do not need to adhere to the tricolor invariant)" | format | <inline: true> ((manager isImmediate: objOop) + or: [manager isYoungObject: objOop]) - or: [manager isYoung: objOop]) ifTrue: [^ false]. self assert: (manager isForwarded: objOop) not. "if it is marked we already did everything we needed to do and if is grey we already saw it and do not have to do anything here" (manager isWhite: objOop) ifFalse: [^false]. format := manager formatOf: objOop. (manager isPureBitsFormat: format) ifTrue: "avoid pushing non-pointer objects on the markStack." ["Avoid tracing classes of non-objects on the heap, e.g. IRC caches, Sista counters." (manager classIndexOf: objOop) > manager lastClassIndexPun ifTrue: [self markAndTraceClassOf: objOop]. "the object does not need to enter the marking stack as there are no pointer to visit -> it is already finished and we can make it black" self blackenObject: objOop. ^false]. (manager isWeakFormat: format) ifTrue: "push weaklings on the weakling stack to scan later" [manager push: objOop onObjStack: manager weaklingStack. "do not follow weak references. They get scanned at the end of marking -> it should be ok to not follow the tricolor invariant" self blackenObject: objOop. ^false]. ((manager isEphemeronFormat: format) and: [manager activeAndDeferredScan: objOop]) ifTrue: [self blackenObject: objOop. ^false]. "we know it is an object that can contain we have to follow" self pushOnMarkingStackAndMakeGrey: objOop. ^ true! Item was changed: ----- Method: SpurIncrementalMarker>>markAndTraceClassOf: (in category 'marking - incremental') ----- markAndTraceClassOf: objOop "Ensure the class of the argument is marked, pushing it on the markStack if not already marked. And for one-way become, which can create duplicate entries in the class table, make sure objOop's classIndex refers to the classObj's actual classIndex. Note that this is recursive, but the metaclass chain should terminate quickly." <inline: false> | classIndex classObj realClassIndex | classIndex := manager classIndexOf: objOop. + "(self testAndSetClassIndex: classIndex) ifTrue: [^ self]." + classObj := manager classOrNilAtIndex: classIndex. self assert: (coInterpreter objCouldBeClassObj: classObj). realClassIndex := manager rawHashBitsOf: classObj. (classIndex ~= realClassIndex and: [classIndex > manager lastClassIndexPun]) ifTrue: [manager setClassIndexOf: objOop to: realClassIndex]. "classObj = 16rAEC3C8 ifTrue: [self halt]." + (manager isWhite: classObj) + ifTrue: ["classes in young space do not get deleted + we do not want to color young space objects" + (manager isOldObject: classObj) + ifTrue: [self pushOnMarkingStackAndMakeGrey: classObj]. + + self flag: #Todo. "we should not need mark and trace class of here, because we push the object on + the marking stack and during tracing the object we will trace its class too" + self markAndTraceClassOf: classObj] + ! - (manager isWhite: classObj) ifTrue: - [ - "classes in young space do not get deleted + we do not want to color young space objects" - (manager isOldObject: classObj) - ifTrue: [self pushOnMarkingStackAndMakeGrey: classObj]. - self markAndTraceClassOf: classObj]! Item was changed: ----- Method: SpurIncrementalMarker>>markFrom:nSlots:of: (in category 'as yet unclassified') ----- markFrom: startIndex nSlots: anAmount of: objOop + - startIndex to: startIndex + anAmount - 1 do: [:index | | slot | slot := manager fetchPointer: index ofObject: objOop. + - (manager isNonImmediate: slot) ifTrue: [ - self flag: #Todo. "can we use unchecked fix?" (manager isForwarded: slot) + ifTrue: [ + "use unchecked and the separate generational barrier to not trigger the normal tricolor write barrier. + After resolving the forwarder we proceed to trace to followed value => we cannot lose it" + slot := manager uncheckedFixFollowedField: index ofObject: objOop withInitialValue: slot. + manager gc generationalBarrierFor: objOop at: index with: slot]. - ifTrue: [slot := manager fixFollowedField: index ofObject: objOop withInitialValue: slot]. self markAndShouldScan: slot]]! Item was changed: ----- Method: SpurIncrementalMarker>>pushNewSpaceReferencesOnMarkingStack (in category 'root-scanning') ----- pushNewSpaceReferencesOnMarkingStack + manager allNewSpaceObjectsDo: [:objOop | | obj format | + obj := manager followMaybeForwarded: objOop. + format := manager formatOf: obj. - manager allNewSpaceObjectsDo: [:objOop | | format | - format := manager formatOf: objOop. + self markAndTraceClassOf: obj. - self markAndTraceClassOf: objOop. "has the object pointers to visit?" + ((manager isNonImmediate: obj) and: [(manager isPureBitsFormat: format) not]) - ((manager isNonImmediate: objOop) and: [(manager isPureBitsFormat: format) not]) ifTrue: [ | slotNumber | + slotNumber := manager numStrongSlotsOfInephemeral: obj. - slotNumber := manager numStrongSlotsOfInephemeral: objOop. 0 to: slotNumber - 1 do: [ :slotIndex | | slot | + slot := manager fetchPointer: slotIndex ofObject: obj. - slot := manager fetchPointer: slotIndex ofObject: objOop. (self shoudlBeOnMarkingStack: slot) ifTrue: [self markAndShouldScan: slot]]]] ! Item was removed: - ----- Method: SpurIncrementalMarker>>resolveAllForwarders (in category 'marking - global') ----- - resolveAllForwarders - - self shouldBeImplemented! Item was added: + ----- Method: SpurIncrementalMarker>>shouldScan: (in category 'testing') ----- + shouldScan: objOop + + | format | + <inline: true> + (manager isImmediate: objOop) ifTrue: + [^false]. + "if markAndTrace: is to follow and eliminate forwarding pointers + in its scan it cannot be handed an r-value which is forwarded." + self assert: (manager isForwarded: objOop) not. + + format := manager formatOf: objOop. + (manager isPureBitsFormat: format) ifTrue: "avoid pushing non-pointer objects on the markStack." + [ ^false]. + (manager isWeakFormat: format) ifTrue: "push weaklings on the weakling stack to scan later" + [^false]. + ((manager isEphemeronFormat: format) + and: [manager activeAndDeferredScan: objOop]) ifTrue: + [^false]. + ^true! Item was added: + ----- Method: SpurIncrementalMarker>>testAndSetClassIndex: (in category 'as yet unclassified') ----- + testAndSetClassIndex: classIndex + + | test entry | + "64 = size of long long" + classIndex > (ClassBitTableSize * 64) ifTrue: [^ false]. + + test := 1 << (classIndex \\ 64). + + entry := classBitTable + at: (self cCode: [classIndex // 64] inSmalltalk: [classIndex // 64 + 1]). + + (entry bitAnd: test) > 0 + ifTrue: [^ true] + ifFalse: [ + classBitTable at: (self cCode: [classIndex // 64] inSmalltalk: [classIndex // 64 + 1]) put: (entry bitOr: test). + ^ false]! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>assertSegmentToFillIsInSegmentsArray (in category 'as yet unclassified') ----- + assertSegmentToFillIsInSegmentsArray + + | segInfo | + compactor segmentToFill ifNil: [^ self]. + + segInfo := manager segInfoAt: manager numSegments - 1. + + self assert: (manager segmentManager segments <= compactor segmentToFill and: [compactor segmentToFill <= segInfo]). + + (manager segmentManager segments <= compactor segmentToFill and: [compactor segmentToFill <= segInfo]) + ifFalse: [manager debugger]! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>giveSegmentToFillBackToMemoryManager (in category 'as yet unclassified') ----- + giveSegmentToFillBackToMemoryManager + + "part of gcForSnapshot. only intented to be run after a complete incremental gc cycle is done (just before starting + the next marking pass)" + + compactor segmentToFill ifNil: [^ self]. + + self assertSegmentToFillIsInSegmentsArray. + self assert: (manager isEmptySegment: compactor segmentToFill). + + manager + addFreeChunkWithBytes: compactor segmentToFill segSize - manager bridgeSize + at: compactor segmentToFill segStart. + + "we have compacted into segmentToFill. It is now not empty anymore and we need to look for a new one" + compactor setSegmentToFillToAddress: nil + + ! Item was changed: SpurCompactor subclass: #SpurIncrementalSweeper + instanceVariableNames: 'currentSweepingEntity isCurrentlySweeping currentSegmentUsed currentSegmentUnused currentSegmentsIndex currentsCycleSeenObjectCount currentSegmentsBridge sStartTime lilliputianList lilliputianListSize lilliputianListEnd sweepingStart sweptEntities' - instanceVariableNames: 'currentSweepingEntity isCurrentlySweeping currentSegmentUsed currentSegmentUnused currentSegmentsIndex currentsCycleSeenObjectCount currentSegmentsBridge' classVariableNames: 'MaxObjectsToFree' poolDictionaries: '' category: 'VMMaker-SpurGarbageCollector'! Item was changed: ----- Method: SpurIncrementalSweeper>>canUseAsFreeSpace: (in category 'testing') ----- canUseAsFreeSpace: objOop <inline: true> + ^ (manager isFreeObject: objOop) or: [manager isWhite: objOop]! - ^ (manager isFreeObject: objOop) or: [(manager isMarked: objOop) not]! Item was changed: ----- Method: SpurIncrementalSweeper>>cautiousBulkFreeChunkFrom: (in category 'api - incremental') ----- cautiousBulkFreeChunkFrom: objOop "The old space entity before objOop is necessarily a marked object. Attempts to free as many bytes from objOop start as possible, looking ahead to free contiguous freechunks / unmarked objects" | bytes start next currentObj | self assert: (self canUseAsFreeSpace: objOop). start := manager startOfObject: objOop. currentObj := objOop. bytes := 0. + [| objSize | + sweptEntities := sweptEntities + 1. + objSize := (manager bytesInBody: currentObj). + bytes := bytes + objSize. - [bytes := bytes + (manager bytesInBody: currentObj). (manager isRemembered: currentObj) ifTrue: [self assert: (manager isFreeObject: currentObj) not. scavenger forgetObject: currentObj]. (manager isFreeObject: currentObj) ifTrue: [ "we need to unlink chunks for concurrent sweeping. In the stop the world sweeper we can just reset the freeLists but here we need to keep them around so the mutator can still work between sweeping passes" self flag: #Todo. "we want to optimize for lilliputian chunks!! For now it is ok(ish) but we have to do something about it. At the moment I see 3 possibilities: - have the lilliputian list always sorted (O(n) insert in the worst case!!) - sort the lilliputian part before sweeping (O(n log n) at the start. but everytime before sweeping) + - be cheeky and discard the lilliputian list (problem: the mutator has no access to the list + it can insert unsorted chunks (for the duration of sweeping we could let it use a second list and just append it after sweeping)" + "(manager isLilliputianSize: objSize) + ifTrue: [ | nextLilliputian | + nextLilliputian := (manager fetchPointer: manager freeChunkNextIndex ofFreeChunk: currentObj). + manager + noCheckPush: nextLilliputian + onObjStack: manager markStack] + ifFalse: [manager detachFreeObject: currentObj]" + manager detachFreeObject: currentObj + - - be cheeky and discard the lilliputian list (problem: the mutator has no access to the list + it can insert unsorted chunks (for the duration of sweeping we could let it use a second list and just append it after sweeping)" - manager detachFreeObject: currentObj. "self assert: manager totalFreeOldSpace = manager totalFreeListBytes."]. next := manager objectStartingAt: start + bytes. currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1. self assert: ((manager oop: next isLessThan: manager endOfMemory) or: [next = manager endOfMemory and: [(self canUseAsFreeSpace: next) not]]). "should the next object not be usable as free space (because it is marked) abort the loop. Attention: briges at the end of segments are marked and therefore we leave the loop here. This is important as the newly created free space segment should not be bigger than there still is space left in the current segment" + (self canUseAsFreeSpace: next) and: [coInterpreter ioUTCMicrosecondsNow - sStartTime < 5000]] - (self canUseAsFreeSpace: next) and: [currentsCycleSeenObjectCount < MaxObjectsToFree]] whileTrue: [currentObj := next]. currentSegmentUnused := currentSegmentUnused + bytes. + "^ self interceptAddFreeChunkWithBytes: bytes at: start" ^ manager addFreeChunkWithBytes: bytes at: start! Item was added: + ----- Method: SpurIncrementalSweeper>>cleanUpLilliputianChunks (in category 'as yet unclassified') ----- + cleanUpLilliputianChunks + + "- remove all lilliputian chunks in the range of this sweep + - patch the lilliputian free list with the saved values on the MarkStack + - append all newly created (or already existing but previously here removed) lilliputian chunks" + + self flag: #Todo. "it would be nicer if we appened lilliputian chunk lists instead of prepending. Not sure if it has any preformance impact" + + (manager isEmptyObjStack: manager markStack) not + ifTrue: [ | node prev | + node := manager freeLists at: 2. + + prev := 0. + [node ~= 0] + whileTrue: [ + (node >= sweepingStart and: [node < currentSweepingEntity]) + ifTrue: [ + self assert: (manager sizeOfObjStack: manager markStack) > 0. + node := (manager popObjStack: manager markStack). + + (node = 0 and: [(manager sizeOfObjStack: manager markStack) > 0]) + ifTrue: [ + node := (manager popObjStack: manager markStack). + manager noCheckPush: 0 onObjStack: manager markStack]. + + manager totalFreeOldSpace: manager totalFreeOldSpace - manager lilliputianChunkSize. + + prev = 0 + ifTrue: [manager freeLists at: 2 put: node] + ifFalse: [manager setNextFreeChunkOf: prev withValue: node isLilliputianSize: true]] + ifFalse: [prev := node. + node := (manager fetchPointer: manager freeChunkNextIndex ofFreeChunk: node)]]]. + + self assert: (manager isEmptyObjStack: manager markStack). + + lilliputianListEnd ~= 0 + ifTrue: [ + manager setNextFreeChunkOf: lilliputianListEnd withValue: (manager freeLists at: 2) isLilliputianSize: true. + manager freeLists at: 2 put: lilliputianList. + manager totalFreeOldSpace: manager totalFreeOldSpace + (lilliputianListSize * manager lilliputianChunkSize)]. + + self assert: manager totalFreeOldSpace = manager totalFreeListBytes. + + "update free lists mask just to be sure as we probably manipulated it here" + (manager freeLists at: 2) = 0 + ifTrue: [manager freeListsMask: (manager freeListsMask bitClear: 2)] + ifFalse: [manager freeListsMask: (manager freeListsMask bitOr: 2r100)]. + + self assert: manager bitsSetInFreeSpaceMaskForAllFreeLists + ! Item was changed: ----- Method: SpurIncrementalSweeper>>doIncrementalSweeping (in category 'api - incremental') ----- doIncrementalSweeping - "Scan the heap for unmarked objects and free them. Coalescence " self assert: currentSweepingEntity notNil. currentsCycleSeenObjectCount := 0. [self oop: currentSweepingEntity isLessThan: manager endOfMemory] whileTrue: [ currentSweepingEntity = currentSegmentsBridge ifTrue: [self advanceSegment] ifFalse: [self sweepFromCurrentSweepingEntity]. currentSweepingEntity := self nextSweepingEntity. + "do not end on a bridge. While the mutator runs the bridge can get an overhead header and we wouldn't handle that correctly + -> avoid this case" + (currentSweepingEntity ~= currentSegmentsBridge + and: [(manager segmentManager isEmptySegment: (manager segInfoAt: currentSegmentsIndex)) not + and: [coInterpreter ioUTCMicrosecondsNow - sStartTime >= 5000]]) - currentsCycleSeenObjectCount >= MaxObjectsToFree ifTrue: [^ false]]. "set occupation for last segment" self setOccupationAtIndex: currentSegmentsIndex used: currentSegmentUsed unused: currentSegmentUnused. manager checkFreeSpace: GCModeIncremental. ^ true! Item was changed: ----- Method: SpurIncrementalSweeper>>incrementalSweep (in category 'api - incremental') ----- incrementalSweep <inline: #never> "for profiling" self initIfNecessary. "should in between sweeper calls segments be removed the index would not be correct anymore. Reset it here so we can be sure it is correct" currentSegmentsIndex := manager segmentManager segmentIndexContainingObj: currentSweepingEntity. "if the bridge between segments was small before and the segment directly after the current one was removed the position of the bridge moved. Update the current position to avoid this case" currentSegmentsBridge := manager segmentManager bridgeAt: currentSegmentsIndex. + sweepingStart := currentSweepingEntity. + lilliputianList := 0. + lilliputianListEnd := 0. + lilliputianListSize := 0. + self assert: manager validObjectColors. + sStartTime := coInterpreter ioUTCMicrosecondsNow. + self doIncrementalSweeping + ifTrue: [ + "self cleanUpLilliputianChunks." + self finishSweeping. - ifTrue: [self finishSweeping. ^ true]. + + "self cleanUpLilliputianChunks." - ^ false ! Item was changed: ----- Method: SpurIncrementalSweeper>>initIfNecessary (in category 'api - incremental') ----- initIfNecessary isCurrentlySweeping ifFalse: [currentSegmentUsed := currentSegmentUnused := 0. currentSegmentsIndex := 0. currentSegmentsBridge := manager segmentManager bridgeAt: currentSegmentsIndex. + + "we cheat a bit and use the mark stack for lilliputian chunks" + manager initializeMarkStack. currentSweepingEntity := manager firstObject. + sweptEntities := 0. + isCurrentlySweeping := true] ! Item was changed: ----- Method: SpurIncrementalSweeper>>initialize (in category 'initialize-release') ----- initialize super initialize. + isCurrentlySweeping := false. + sweptEntities := 0! - isCurrentlySweeping := false! Item was added: + ----- Method: SpurIncrementalSweeper>>interceptAddFreeChunkWithBytes:at: (in category 'as yet unclassified') ----- + interceptAddFreeChunkWithBytes: bytes at: address + + ^ (manager isLilliputianSize: bytes) + ifTrue: [ | chunk | + chunk := manager initFreeChunkWithBytes: bytes at: address. + lilliputianListEnd = 0 ifTrue: [lilliputianListEnd := chunk]. + manager setNextFreeChunkOf: chunk withValue: lilliputianList isLilliputianSize: true. + lilliputianList := chunk. + lilliputianListSize := lilliputianListSize + 1. + chunk] + ifFalse: [manager addFreeChunkWithBytes: bytes at: address]! Item was changed: ----- Method: SpurIncrementalSweeper>>setOccupationAtIndex:used:unused: (in category 'compactor support') ----- setOccupationAtIndex: segmentIndex used: used unused: unused "WARNING: Resets the isCompacted bit" "Swizzle is abused bit 16 isBeingCompacted bits 0-15 occupation Setting occupation resets the claim bit" | occupation segInfo | <var: 'segInfo' type: #'SpurSegmentInfo *'> + "coInterpreter cr; print: '-------------------------------'; cr; flush. - coInterpreter cr; print: '-------------------------------'; cr; flush. coInterpreter cr; print: 'Segment '; printNum: segmentIndex; print: ' is occupied to: '; printNum: (used asFloat / (used + unused)) * 100; print: '%'; cr; print: 'used: '; printNum: used; cr; + print: 'unused: '; printNum: unused; tab; flush; cr." - print: 'unused: '; printNum: unused; tab; flush; cr. coInterpreter cr; print: '-------------------------------'; cr; flush. segInfo := manager segInfoAt: segmentIndex. "careful with overflow here..." occupation := ((used asFloat / (used + unused)) * 16rFFFF) asInteger. self assert: (occupation between: 0 and: 16rFFFF). segInfo swizzle: occupation! Item was changed: ----- Method: SpurIncrementalSweeper>>sweepFromCurrentSweepingEntity (in category 'api - incremental') ----- sweepFromCurrentSweepingEntity (self canUseAsFreeSpace: currentSweepingEntity) ifTrue: [currentSweepingEntity := self cautiousBulkFreeChunkFrom: currentSweepingEntity] + ifFalse: [self unmarkAndUpdateStats. sweptEntities := sweptEntities + 1]. - ifFalse: [self unmarkAndUpdateStats]. ! Item was added: + ----- Method: SpurIncrementalSweeper>>sweptEntities (in category 'as yet unclassified') ----- + sweptEntities + + ^ sweptEntities! Item was changed: ----- Method: SpurMemoryManager class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator self wantsIncrementalGC ifTrue: [aCCodeGenerator recursivelyResolvePolymorpicReceiver: 'gc' toVariants: {SpurIncrementalGarbageCollector. SpurStopTheWorldGarbageCollector} in: self default: SpurIncrementalGarbageCollector; staticallyResolvedPolymorphicReceiver: 'gc' to: self markerClass in: SpurIncrementalGarbageCollector; staticallyResolvedPolymorphicReceiver: 'compactor' to: self compactorClass in: self; staticallyResolvedPolymorphicReceiver: 'marker' to: self markerClass in: self]. self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses" aCCodeGenerator removeVariable: 'memory'. "memory is a simulation time thing only" self declareCAsOop: #( freeStart scavengeThreshold newSpaceStart pastSpaceStart oldSpaceStart lowSpaceThreshold freeOldSpaceStart endOfMemory) in: aCCodeGenerator. self declareCAsUSqLong: (self allInstVarNames select: [:ivn| ivn endsWith: 'Usecs']), #(statAllocatedBytes) in: aCCodeGenerator. aCCodeGenerator var: #lastHash type: #usqInt; var: #freeListsMask type: #usqInt; var: #freeLists type: #'sqInt *'; var: #objStackInvalidBecause type: #'char *'; var: #unscannedEphemerons type: #SpurContiguousObjStack; var: #heapGrowthToSizeGCRatio type: #float; var: #heapSizeAtPreviousGC type: #usqInt; var: #totalFreeOldSpace type: #usqInt; var: #maxOldSpaceSize type: #usqInt. aCCodeGenerator var: #oldSpaceUsePriorToScavenge type: #sqLong. aCCodeGenerator var: #remapBuffer declareC: 'sqInt remapBuffer[RemapBufferSize + 1 /* ', (RemapBufferSize + 1) printString, ' */]'. aCCodeGenerator var: #extraRoots declareC: 'sqInt *extraRoots[ExtraRootsSize + 1 /* ', (ExtraRootsSize + 1) printString, ' */]'. + - - aCCodeGenerator - staticallyResolvedPolymorphicReceiver: 'objectMemory gc' - to: (Smalltalk classNamed: (InitializationOptions at: 'gcClass')) - in: StackInterpreter. self wantsIncrementalGC + ifTrue: [ + aCCodeGenerator - ifTrue: [aCCodeGenerator staticallyResolvedPolymorphicReceiver: 'manager gc' to: SpurIncrementalGarbageCollector in: SpurSegmentManager; + staticallyResolvedPolymorphicReceiver: 'objectMemory gc' to: self gcClass in: StackInterpreter; "the vm needs (from handwritten C code) the method fullGC. Generate it later on" generate: #fullGC from: #SIGC_fullGC]! Item was changed: ----- Method: SpurMemoryManager>>classOrNilAtIndex: (in category 'class table') ----- classOrNilAtIndex: classIndex <api> | classTablePage | self assert: (classIndex <= self tagMask or: [classIndex >= self arrayClassIndexPun]). - (classIndex <= self tagMask or: [classIndex >= self arrayClassIndexPun]) - ifFalse: [self cCode: 'raise(SIGINT)']. classTablePage := self fetchPointer: classIndex >> self classTableMajorIndexShift ofObject: hiddenRootsObj. classTablePage = nilObj ifTrue: [^nilObj]. ^self fetchPointer: (classIndex bitAnd: self classTableMinorIndexMask) ofObject: classTablePage! Item was added: + ----- Method: SpurMemoryManager>>debugger (in category 'plugin support') ----- + debugger + + <inline: #never> + self cCode: 'raise(SIGINT)'! Item was changed: ----- Method: SpurMemoryManager>>ensureRoomOnObjStackAt: (in category 'obj stacks') ----- ensureRoomOnObjStackAt: objStackRootIndex "An obj stack is a stack of objects stored in a hidden root slot, such as the markStack or the ephemeronQueue. It is a linked list of segments, with the hot end at the head of the list. It is a word object. The stack pointer is in ObjStackTopx and 0 means empty. The list goes through ObjStackNextx. We don't want to shrink objStacks, since they're used in GC and its good to keep their memory around. So unused pages created by popping emptying pages are kept on the ObjStackFreex list." | stackOrNil freeOrNewPage | stackOrNil := self fetchPointer: objStackRootIndex ofObject: hiddenRootsObj. (stackOrNil = nilObj or: [(self fetchPointer: ObjStackTopx ofObject: stackOrNil) >= ObjStackLimit]) ifTrue: [freeOrNewPage := stackOrNil = nilObj ifTrue: [0] ifFalse: [self fetchPointer: ObjStackFreex ofObject: stackOrNil]. freeOrNewPage ~= 0 ifTrue: "the free page list is always on the new page." [self storePointer: ObjStackFreex ofObjStack: stackOrNil withValue: 0. self assert: (marker marking not or: [self isMarked: freeOrNewPage])] ifFalse: [freeOrNewPage := self allocateSlotsInOldSpace: ObjStackPageSlots format: self wordIndexableFormat classIndex: self wordSizeClassIndexPun. freeOrNewPage ifNil: ["Allocate a new segment an retry. This is very uncommon. But it happened to me (Clement)." self growOldSpaceByAtLeast: ObjStackPageSlots. freeOrNewPage := self allocateSlotsInOldSpace: ObjStackPageSlots format: self wordIndexableFormat classIndex: self wordSizeClassIndexPun. freeOrNewPage ifNil: [self error: 'no memory to allocate or extend obj stack']]. self storePointer: ObjStackFreex ofObjStack: freeOrNewPage withValue: 0. + + "when marking default to mark new pages, because they get only marked at the beginning and not later on" + marker marking ifTrue: [self setIsMarkedOf: freeOrNewPage to: true]. - marker marking ifTrue: [self setIsMarkedOf: freeOrNewPage to: true]. gc maybeModifyGCFlagsOf: freeOrNewPage]. self storePointer: ObjStackMyx ofObjStack: freeOrNewPage withValue: objStackRootIndex; storePointer: ObjStackNextx ofObjStack: freeOrNewPage withValue: (stackOrNil = nilObj ifTrue: [0] ifFalse: [stackOrNil]); storePointer: ObjStackTopx ofObjStack: freeOrNewPage withValue: 0; storePointer: objStackRootIndex ofObject: hiddenRootsObj withValue: freeOrNewPage. self assert: (self isValidObjStackAt: objStackRootIndex). "Added a new page; now update and answer the relevant cached first page." stackOrNil := self updateRootOfObjStackAt: objStackRootIndex with: freeOrNewPage]. self assert: (self isValidObjStackAt: objStackRootIndex). ^stackOrNil! Item was changed: ----- Method: SpurMemoryManager>>freeChunkWithBytes:at: (in category 'free space') ----- freeChunkWithBytes: bytes at: address <inline: false> | freeChunk | self assert: (self isInOldSpace: address). - (segmentManager segmentContainingObj: address) = (segmentManager segmentContainingObj: address + bytes) - ifFalse: [self cCode: 'raise(SIGINT)']. self assert: (segmentManager segmentContainingObj: address) = (segmentManager segmentContainingObj: address + bytes). freeChunk := self initFreeChunkWithBytes: bytes at: address. self addToFreeList: freeChunk bytes: bytes. self assert: freeChunk = (self objectStartingAt: address). ^freeChunk! Item was added: + ----- Method: SpurMemoryManager>>freeListsMask (in category 'accessing') ----- + freeListsMask + + ^ freeListsMask! Item was added: + ----- Method: SpurMemoryManager>>freeListsMask: (in category 'accessing') ----- + freeListsMask: newMask + + freeListsMask := newMask! Item was changed: ----- Method: SpurMemoryManager>>isWhiteOrBogusGrey: (in category 'header access') ----- isWhiteOrBogusGrey: objOop "Answer if the object is either white, or grey but unmarked" + ^(self isWhite: objOop) or: [(self isGrey: objOop) and: [(self is: objOop onObjStack: markStack) not]]! - ^(self isMarked: objOop) not! Item was changed: ----- Method: SpurMemoryManager>>lilliputianChunkIndex (in category 'free space') ----- lilliputianChunkIndex "See isLilliputianSize:" + ^self lilliputianChunkSize // self allocationUnit - ^(self baseHeaderSize + self allocationUnit) // self allocationUnit ! Item was added: + ----- Method: SpurMemoryManager>>lilliputianChunkSize (in category 'free space') ----- + lilliputianChunkSize + + ^ self baseHeaderSize + self allocationUnit + ! Item was changed: ----- Method: SpurMemoryManager>>nilUnmarkedWeaklingSlotsIn:excludingYoungObjects: (in category 'weakness and ephemerality') ----- nilUnmarkedWeaklingSlotsIn: aWeakling excludingYoungObjects: aBoolean "Nil the unmarked slots in aWeakling and answer if any unmarked slots were found." <inline: true> | anyUnmarked | anyUnmarked := false. self assert: (self allStrongSlotsOfWeaklingAreMarked: aWeakling excludingYoungObjects: aBoolean). "N.B. generateToByDoLimitExpression:negative:on: guards against (unsigned)0 - 1 going +ve" (self numStrongSlotsOfWeakling: aWeakling) to: (self numSlotsOf: aWeakling) - 1 do: [:i| | referent | referent := self fetchPointer: i ofObject: aWeakling. (self isNonImmediate: referent) ifTrue: + [(self isUnambiguouslyForwarder: referent) + ifTrue: + [referent := self uncheckedFixFollowedField: i ofObject: aWeakling withInitialValue: referent. - [(self isUnambiguouslyForwarder: referent) ifTrue: - [ - referent := self uncheckedFixFollowedField: i ofObject: aWeakling withInitialValue: referent. ((self isOldObject: aWeakling) and: [(self isYoungObject: referent) and: [(self isRemembered: aWeakling) not]]) ifTrue: [scavenger remember: aWeakling]]. + + ((self isImmediate: referent) or: [self isMarked: referent]) + ifFalse: [((self isYoungObject: referent) and: [aBoolean]) - ((self isImmediate: referent) or: [self isMarked: referent]) ifFalse: - [((self isYoung: referent) and: [aBoolean]) ifFalse: [self storePointerUnchecked: i ofObject: aWeakling withValue: nilObj. anyUnmarked := true]]]]. ^anyUnmarked! Item was changed: ----- Method: SpurMemoryManager>>numSlotsOf: (in category 'object access') ----- numSlotsOf: objOop <returnTypeC: #usqInt> <api> | numSlots | self flag: #endianness. "numSlotsOf: should not be applied to free or forwarded objects." self assert: (self classIndexOf: objOop) > self isForwardedObjectClassIndexPun. - (self classIndexOf: objOop) > self isForwardedObjectClassIndexPun - ifFalse: [self cCode: 'raise(SIGINT)']. numSlots := self rawNumSlotsOf: objOop. ^numSlots = self numSlotsMask "overflow slots; (2^32)-1 slots are plenty" ifTrue: [self rawOverflowSlotsOf: objOop] ifFalse: [numSlots]! Item was changed: ----- Method: SpurMemoryManager>>printFreeSpaceStatistics (in category 'debug printing') ----- printFreeSpaceStatistics "used for debugging" <export: true> <var: 'sizeCount' declareC:'static unsigned long long sizeCount[64] = {0}'> | sizeCount | self cCode:'' inSmalltalk:[ sizeCount := CArrayAccessor on: (DoubleWordArray new: 64). ]. coInterpreter cr; print: '----------------------------------------- '; cr; print: '----------------------------------------- '; cr. 0 to: self numSegments -1 do: [:index | | segInfo bigFreeChunkMemory freeSpace occupiedSpace objectCount | segInfo := self segInfoAt: index. bigFreeChunkMemory := 0. freeSpace := 0. occupiedSpace := 0. objectCount := 0. segmentManager allEntitiesInSegment: segInfo exceptTheLastBridgeDo: [:oop | | oopSize slotCount | oopSize := self bytesInBody: oop. slotCount := oopSize >> 3. (self isFreeOop: oop) ifTrue: [ - "index > 0 - ifTrue: [self cCode: 'raise(SIGINT)']." freeSpace := freeSpace + oopSize. slotCount < 64 ifTrue: [ sizeCount at: slotCount put: ((sizeCount at: slotCount) + 1)] ifFalse: [sizeCount at: 0 put: ((sizeCount at: 0) + 1). bigFreeChunkMemory := bigFreeChunkMemory + oopSize]] ifFalse: [objectCount := objectCount + 1. occupiedSpace := occupiedSpace + oopSize]]. coInterpreter cr; print: 'Segment '; printNum: index; print: ' (starting at: '; printHex: segInfo segStart; tab; + print: ' - '; + printHex: segInfo segStart + segInfo segSize; tab; print: 'max bytes: '; tab; printNum: segInfo segSize; print: ')'; cr; cr; flush. coInterpreter cr; print: 'Currently occupied space: '; tab; printNum: occupiedSpace; tab; print: 'From '; printNum: objectCount; print: ' objects'; cr; print: 'Currently free space: '; tab; printNum: freeSpace; cr; print: 'Resulting in an occupation percentage of: '; tab; printNum: (occupiedSpace asFloat / (occupiedSpace + freeSpace)) * 100; cr; cr; flush. coInterpreter tab; print: 'big free chunks '; printNum: (sizeCount at: 0); print: ' reserving number of bytes: '; printNum: bigFreeChunkMemory; cr; flush. sizeCount at: 0 put: 0. 1 to: 63 do: [:i | (sizeCount at: i) > 0 ifTrue: [coInterpreter tab; print: 'free chunk of size '; printNum: i; print: ': '; printNum: (sizeCount at: i); cr; flush. sizeCount at: i put: 0.]]. coInterpreter cr; print: '----------------------------------------- '; cr.]. coInterpreter cr; print: '----------------------------------------- '; cr; print: '----------------------------------------- '; cr. ! Item was changed: ----- Method: SpurMemoryManager>>printFreeSpaceStatisticsWithUnmarkedAsFreeSpace (in category 'debug printing') ----- printFreeSpaceStatisticsWithUnmarkedAsFreeSpace "used for debugging" <export: true> <var: 'sizeCount' declareC:'static unsigned long long sizeCount[64] = {0}'> | sizeCount | self cCode:'' inSmalltalk:[ sizeCount := CArrayAccessor on: (DoubleWordArray new: 64). ]. coInterpreter cr; print: '----------------------------------------- '; cr; print: '----------------------------------------- '; cr. 0 to: self numSegments -1 do: [:index | | segInfo bigFreeChunkMemory freeSpace occupiedSpace objectCount | segInfo := self segInfoAt: index. bigFreeChunkMemory := 0. freeSpace := 0. occupiedSpace := 0. objectCount := 0. segmentManager allEntitiesInSegment: segInfo exceptTheLastBridgeDo: [:oop | | oopSize slotCount | oopSize := self bytesInBody: oop. slotCount := oopSize >> 3. + ((self isFreeOop: oop) or: [(self isMarked: oop) not]) - (self isFreeOop: oop) ifTrue: [ freeSpace := freeSpace + oopSize. slotCount < 64 ifTrue: [ sizeCount at: slotCount put: ((sizeCount at: slotCount) + 1)] ifFalse: [sizeCount at: 0 put: ((sizeCount at: 0) + 1). bigFreeChunkMemory := bigFreeChunkMemory + oopSize]] ifFalse: [objectCount := objectCount + 1. occupiedSpace := occupiedSpace + oopSize]]. coInterpreter cr; print: 'Segment '; printNum: index; print: ' (starting at: '; printHex: segInfo segStart; tab; print: 'max bytes: '; tab; printNum: segInfo segSize; print: ')'; cr; cr; flush. coInterpreter cr; print: 'Currently occupied space: '; tab; printNum: occupiedSpace; tab; print: 'From '; printNum: objectCount; print: ' objects'; cr; print: 'Currently free space: '; tab; printNum: freeSpace; cr; print: 'Resulting in an occupation percentage of: '; tab; printNum: (occupiedSpace asFloat / (occupiedSpace + freeSpace)) * 100; cr; cr; flush. coInterpreter tab; print: 'big free chunks '; printNum: (sizeCount at: 0); print: ' reserving number of bytes: '; printNum: bigFreeChunkMemory; cr; flush. sizeCount at: 0 put: 0. 1 to: 63 do: [:i | (sizeCount at: i) > 0 ifTrue: [coInterpreter tab; print: 'free chunk of size '; printNum: i; print: ': '; printNum: (sizeCount at: i); cr; flush. sizeCount at: i put: 0.]]. coInterpreter cr; print: '----------------------------------------- '; cr.]. coInterpreter cr; print: '----------------------------------------- '; cr; print: '----------------------------------------- '; cr. ! Item was added: + ----- Method: SpurMemoryManager>>printInfo: (in category 'debug printing') ----- + printInfo: objOop + + <export: true> + + coInterpreter + print: 'the object '; print: (coInterpreter whereIs: objOop); tab; flush. + + (self isOldObject: objOop) + ifTrue: [ | segmentIndex segInfo | + segmentIndex := self segmentManager segmentIndexContainingObj: objOop. + segInfo := self segInfoAt: segmentIndex. + coInterpreter cr; + print: 'in segment '; printNum: segmentIndex; tab; + print: '('; printHexnp: segInfo segStart; + print: ' - '; + printHexnp: segInfo segStart + segInfo segSize; print: ')'; + cr; flush.]. + + + (self isImmediate: objOop) + ifTrue: [coInterpreter cr; + print: 'immediate '; tab; flush. + ^ self]. + + (self isForwarded: objOop) + ifTrue: [coInterpreter cr; print: 'forwarder to: '; printHexnp: (self fetchPointer: 0 ofObject: objOop)] + ifFalse: [| class className length | + class := self fetchClassOfNonImm: objOop. + className := coInterpreter nameOfClass: class lengthInto: (self addressOf: length put: [:v| length := v]). + coInterpreter cr; printHexnp: objOop; tab; print: className; tab; + print: 'format: '; printNum: (self formatOf: objOop); tab; + print: 'size: '; printNum: (self bytesInBody: objOop)]. + + coInterpreter cr; + print: 'marked '; printNum: (self isMarked: objOop); tab; + print: 'grey '; printNum: (self isGrey: objOop); tab; + print: 'remembered '; printNum: (self isRemembered: objOop); tab; + print: 'pinned '; printNum: (self isPinned: objOop); cr; flush.! Item was changed: ----- Method: SpurMemoryManager>>push:onObjStack: (in category 'obj stacks') ----- push: objOop onObjStack: objStack <inline: true> self assert: (self addressCouldBeOop: objOop). - (gc isIncremental and: [objStack = self markStack and: [self isYoung: objOop]] ) - ifTrue: [self cCode: 'raise(SIGINT)']. (self isImmediate: objOop) ifTrue: [self assert: objStack = markStack. self assert: (self addressCouldBeObj: (self topOfObjStack: (0 = (self fetchPointer: ObjStackTopx ofObject: objStack) ifTrue: [self fetchPointer: ObjStackNextx ofObject: objStack] ifFalse: [objStack])))] ifFalse: "There should be no weaklings on the mark stack." [self assert: (objStack = markStack and: [self isWeakNonImm: objOop]) not. "There should only be weaklings on the weaklingStack" self assert: (objStack ~= weaklingStack or: [self isWeakNonImm: objOop])]. ^self noCheckPush: objOop onObjStack: objStack! Item was changed: ----- Method: SpurMemoryManager>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') ----- (excessive size, no diff calculated) Item was changed: ----- Method: SpurMemoryManager>>storePointer:ofObject:withValue: (in category 'object access') ----- storePointer: fieldIndex ofObject: objOop withValue: valuePointer <api> "See SistaCogit" "Note must check here for stores of young objects into old ones." <inline: true> self assert: (self isForwarded: objOop) not. - (self isForwarded: objOop) - ifTrue: [self cCode: 'raise(SIGINT)']. - (self isOldObject: objOop) ifTrue: "most stores into young objects" - [(self isYoung: valuePointer) ifTrue: - [self possibleRootStoreInto: objOop]]. - self longAt: objOop + self baseHeaderSize + (fieldIndex << self shiftForWord) put: valuePointer. gc writeBarrierFor: objOop at: fieldIndex with: valuePointer. ^ valuePointer! Item was changed: ----- Method: SpurStopTheWorldGarbageCollector>>fullGC (in category 'global') ----- fullGC "Perform a full eager compacting GC. Answer the size of the largest free chunk." <returnTypeC: #usqLong> <inline: #never> "for profiling" manager needGCFlag: 0. manager gcStartUsecs: coInterpreter ioUTCMicrosecondsNow. manager statMarkCount: 0. coInterpreter preGCAction: GCModeFull. self globalGarbageCollect. coInterpreter postGCAction: GCModeFull. manager statGCEndUsecs: coInterpreter ioUTCMicrosecondsNow. manager updateFullGCStats. ^(manager freeLists at: 0) ~= 0 + ifTrue: [manager bytesInBody: manager findLargestFreeChunk] - ifTrue: [self bytesInBody: manager findLargestFreeChunk] ifFalse: [0]! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>gcIdentifier (in category 'as yet unclassified') ----- + gcIdentifier + + ^ 0! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>generationalBarrierFor:at:with: (in category 'barrier') ----- + generationalBarrierFor: anObject at: index with: value + "generational barrier" + + (manager isOldObject: anObject) ifTrue: "most stores into young objects" + [(manager isYoung: value) ifTrue: + [manager possibleRootStoreInto: anObject]].! Item was changed: ----- Method: SpurStopTheWorldGarbageCollector>>globalGarbageCollect (in category 'as yet unclassified') ----- globalGarbageCollect <inline: true> "inline into fullGC" self cCode: [] inSmalltalk: [manager preGlobalGCActions]. + self assert: manager validObjStacks. + self assert: (manager isEmptyObjStack: manager markStack). + self assert: (manager isEmptyObjStack: manager weaklingStack). - self assert: self validObjStacks. - self assert: (self isEmptyObjStack: manager markStack). - self assert: (self isEmptyObjStack: manager weaklingStack). "Mark objects /before/ scavenging, to empty the rememberedTable of unmarked roots." self markObjects: true. manager gcMarkEndUsecs: coInterpreter ioUTCMicrosecondsNow. scavenger forgetUnmarkedRememberedObjects. coInterpreter setGCMode: GCModeNewSpace. self doScavenge: MarkOnTenure. coInterpreter setGCMode: GCModeFull. "Mid-way the leak check must be more lenient. Unmarked classes will have been expunged from the table, but unmarked instances will not yet have been reclaimed." manager runLeakCheckerFor: GCModeFull excludeUnmarkedObjs: true classIndicesShouldBeValid: true. manager compactionStartUsecs: coInterpreter ioUTCMicrosecondsNow. manager segmentManager prepareForGlobalSweep. "for notePinned:" compactor compact. manager attemptToShrink. manager setHeapSizeAtPreviousGC. self assert: manager validObjStacks. self assert: (manager isEmptyObjStack: manager markStack). self assert: (manager isEmptyObjStack: manager weaklingStack). self assert: manager allObjectsUnmarked. manager runLeakCheckerFor: GCModeFull! Item was changed: ----- Method: SpurStopTheWorldGarbageCollector>>writeBarrierFor:at:with: (in category 'barrier') ----- + writeBarrierFor: anObject at: index with: value + + self generationalBarrierFor: anObject at: index with: value! - writeBarrierFor: anObject at: index with: value! Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveGCInfo (in category 'system control primitives') ----- primitiveGCInfo "VM parameters are numbered as follows: 0 stopTheWorld (0) or incremental gc (1) 1 if incremental gc: current gc phase -> 0 marking; 1 sweeping; 2 compacting if stopTheWorld -> -1 2 eden start 3 eden limit 4 freeStart 5 scavengeThreshold 6 amount of old space segments " <staticallyResolveReceiver: 'objectMemory gc' to: #SpurIncrementalGarbageCollector> | result staticCount oldSpaceSegmentCount segmentInfoCount | staticCount := 8. segmentInfoCount := 5. oldSpaceSegmentCount := objectMemory numSegments. result := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: staticCount + (oldSpaceSegmentCount * segmentInfoCount). + objectMemory storePointerUnchecked: 0 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory gc gcIdentifier). - objectMemory storePointerUnchecked: 0 ofObject: result withValue: (objectMemory integerObjectOf: (objectMemory gc isIncremental ifTrue: [1] ifFalse: [0])). objectMemory storePointerUnchecked: 1 ofObject: result withValue: (objectMemory integerObjectOf: (objectMemory gc isIncremental ifTrue: [objectMemory gc phase] ifFalse: [-1])). objectMemory storePointerUnchecked: 2 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory scavenger eden start). objectMemory storePointerUnchecked: 3 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory scavenger eden limit). objectMemory storePointerUnchecked: 4 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory freeStart). objectMemory storePointerUnchecked: 5 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory scavengeThreshold). objectMemory storePointerUnchecked: 6 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory statSurvivorCount). objectMemory storePointerUnchecked: 7 ofObject: result withValue: (self positiveMachineIntegerFor: oldSpaceSegmentCount). 0 to: oldSpaceSegmentCount - 1 do: [:index | | baseIndex segInfo | segInfo := objectMemory segInfoAt: index. baseIndex := staticCount + (index * segmentInfoCount). objectMemory storePointerUnchecked: baseIndex ofObject: result withValue: (objectMemory integerObjectOf: segInfo segStart). objectMemory storePointerUnchecked: baseIndex + 1 ofObject: result withValue: (objectMemory integerObjectOf: segInfo segSize). + objectMemory gc gcIdentifier = 2 + ifTrue: [objectMemory storePointerUnchecked: baseIndex + 2 ofObject: result withValue: (objectMemory integerObjectOf: (segInfo lastFreeObject ifNil: [0]))] + ifFalse: [objectMemory storePointerUnchecked: baseIndex + 2 ofObject: result withValue: (objectMemory integerObjectOf: (segInfo swizzle bitAnd: 16rFFFF))]. + + objectMemory storePointerUnchecked: baseIndex + 3 ofObject: result withValue: (objectMemory integerObjectOf: (segInfo containsPinned ifTrue: [1] ifFalse: [0])). - objectMemory storePointerUnchecked: baseIndex + 2 ofObject: result withValue: (objectMemory integerObjectOf: (segInfo swizzle bitAnd: 16rFFFF)). - objectMemory storePointerUnchecked: baseIndex + 3 ofObject: result withValue: (objectMemory integerObjectOf: segInfo containsPinned). objectMemory storePointerUnchecked: baseIndex + 4 ofObject: result withValue: (objectMemory integerObjectOf: (segInfo swizzle bitOr: 1 << 16))]. objectMemory beRootIfOld: result. self methodReturnValue: result! Item was changed: Object subclass: #VMMaker + instanceVariableNames: 'inline forBrowser allPlugins internalPlugins externalPlugins platformName sourceDirName platformRootDirName logger interpreterClassName is64BitVM optionsDictionary abortBlock sourceDirectory coreVMDirectory sharedResolver' - instanceVariableNames: 'inline forBrowser allPlugins internalPlugins externalPlugins platformName sourceDirName platformRootDirName logger interpreterClassName is64BitVM optionsDictionary abortBlock sourceDirectory coreVMDirectory' classVariableNames: 'DirNames' poolDictionaries: '' category: 'VMMaker-Building'! !VMMaker commentStamp: 'eem 3/27/2017 15:46' prior: 0! This class coordinates generating sources for the various VMs and the set of plugins that comprise the Cog VM. See the class side for generating all or some configurations. The source is intended to be generated in the context of the opensmalltalk-vm source tree available via git from https://github.com/OpenSmalltalk/opensmalltalk-vm. See VMMaker class>>initialize for the relative locations of this image and the source tree (for example, in the image directory of the opensmalltalk-vm tree). Invoke a single configuration via e.g. VMMaker generateSqueakSpurCog64VM or a set via e.g. VMMaker generateAllConfigurationsUnderVersionControl The source tree on branch Cog at https://github.com/OpenSmalltalk/opensmalltalk-vm is generated via generateAllConfigurationsUnderVersionControl. Note that "Squeak" in these cofiguarations means virtual machines that support various versions of Squeak, Pharo and Cuis smalltalks. IIABDFI. Words to the wise: In the old days, VM sources would be generated per-platform. Now, all the source generated by the above generators and included in https://github.com/OpenSmalltalk/opensmalltalk-vm is separately versioned, and we use only CrossPlatformVMMaker to generate them. All platform-specific variations, such as whether to use a struct to hold the interpreter's global variables, which plugins to include in a VM, etc, are included in the generated osurce. All plugins are generated such that they can be compiled as either internal or external plugins. What specific variations to use are therefore controlled by the platform-specific makefiles, and the decision is deferred from source generation time to VM build time. The source is designed to be platform neutral. This form is chosen carefully to allow VMs to be built from fully checked-in, and hence fully versioned source. Old commentary: This class builds a VM codebase from the in-image and on-file code. The platforms file tree you need can be downloaded via cvs from http://squeak.Sourceforge.net. See also the swiki (http://minnow.cc.gatech.edu/squeak/2106) for instructions. It is fairly configurable as to where directories live and can handle multiple platform's source trees at once. It's main purpose is to allow easy building of source trees with any combination of internal/external/unused plugins to suit your platform needs and capabilities. For example, the Acorn has no need of Sound or AsynchFile plugins since I haven't written any platform code for them. There is a simple UI tool for this VMMakerTool openInWorld will open a reasonably self explanatory tool with balloon help to explain all the fields - and a help window on top of that. There are some simple workspace & inspector commands, allowing scripted building: VMMaker default initializeAllExternal generateEntire for example will build sources for a system with all the plugins external whereas VMMaker default initializeAllInternal generateEntire would build all applicable plugins for internal compilation. (VMMaker forPlatform: 'Mac OS') initializeAllExternal generateEntire would build a source tree for a Mac even on a Windows machine (err, ignoring for now the irritation of lineends). If you have a slightly more complex configuration you want to use, perhaps with Socket and Serial support external (because for your case they are rarely used and saving the space has some value) then you could try (VMMaker default initializeAllInternalBut: #(SocketPlugin SerialPlugin) generateEntire More complex still would be (VMMaker default initializeInternal: #(BitBltPlugin MiscPrimsPlugin FilePlugin) external: #(SocketPlugin ZipPlugin B2DPlugin) which allows you to precisely list all the plugins to use. WARNING If you miss out a plugin you need, it won't be there. This message is really best suited to use by a UI like VMMakerTool. To save a configuration for later use, you need to send #saveConfiguration to an active instance of VMMaker. Obviously you could simply use (VMMaker default initializeAllInternalBut: #(SocketPlugin SerialPlugin) saveConfiguration but inspecting VMMaker default and altering the internalPlugins and externalPlugins or the boolean flags for inline or forBrowser followed by saving the configuration allows ultimate power for now. To load a saved configuration file, use #loadConfigurationFrom: aFilename whilst inspecting a VMMaker. The loaded state will completely override any pre-existing state, so take care. You can generate only parts of the source tree if you wish; as shown above #generateEntire will create the whole collection of internal and external plugins as well as the core VM. To create only the external plugins use #generateExternalPlugins, or create a single plugin with #generateExternalPlugin: name. To assemble the main VM including the internal plugins, use #generateMainVM. The interpreter 'interp.c' file is made with #generateInterpreterFile. You can generate a single internal plugin with #generateInternalPlugin: only if it has already been generated before; this interlocking is intended to make sure the named primitive table in the vm is correct. There are some rules to observe in order to use this:- - under the working directory (by default - you can configure it) you need a directory called 'platforms' (also configurable) with subdirectories named as the platform names returned by Smalltalk platformName (ie unix, RiscOS, Mac OS, etc - this isn't configurable). At the very least you need the one for your own platform and the pseudo-platform called 'Cross'. By adding a 'DirNames' entry for #machineType you can cross 'compile' for some other platform. Now all we need is a cross-compiler for the C code :-) - under this directory you must have a simple structure of directories for each generated plugin that you support on the platform, plus 'vm'. In each directory you place any/all platform specific files (and subdirectories) for that plugin. In 'misc' you can place any miscellaneous files such as makefiles, resources etc. For example, for unix you have platforms/ unix/ plugins/ AsynchFilePlugin / sqUnixAsynchfile.c vm/ sqGnu.h Profile/ misc/ makefile.in util/ ...etc Any plugins requiring platform files that you don't support shouldn't appear in the resulting code tree. If you try to include an unsupported plugin in the list to be made external, the VMMaker simply ignores it. However, if you include it in the list to be made internal you will get an error since that seems like a potentially serious source of confusion. There are three lists of plugins maintained herein:- 1) the list of all known generatable plugins. We scan this list and compare with the supported plugins as indicated by the file tree. 2) the list of chosen internal plugins. 3) the list of chosen external plugins. See initializeAllPlugins, initialiseAllExternal etc for fairly obvious usage. There is also a short list of directory names in the class variable 'DirNames' that you can alter if needed. Known problems:- a) since Squeak has really poor filename handling, you can't simply change the directory names to '/foo/bar/myEvilCodeBase' and expect it to work. You fix file names and I'll fix VMMaker :-) b) Squeak copying of a file loses the assorted permissions, filetype info and other useful bits. To workaround this problem, see the FileCopyPlugin, which provides the platform independent part of a simple access for the OS filecopy capability. So far there are functional plugins for unix, Mac and Acorn. DOS machines appear not to need one. This is less of a problem in practise now that unix, Acorn & Mac no longer copy files from /platforms to /src. inline <Boolean> - is the generated code to be inlined or not forBrowser <Boolean> - is this to be a build for in-Browser use? Only relevent to Macs allPlugins <Collection> - all the known possible plugins internalPlugins <Collection> - the plugins chosen to be generated for internal linking externalPlugins <Collection> - the plugins intended to be external plugins exportList <Collection> - a list of function names exported from plugins intended to be internal platformName <String> - the name of the platform for which we are building a source tree. It is possible to do 'cross-compiles' sourceDirName, platformRootDirName <String> - the name of the directory into which we write the generated sources and the name of the directory where we should find the platforms tree.! Item was added: + ----- Method: VMMaker class>>generateSqueakSpur2PhaseIncrementalStackCog64VM (in category 'configurations') ----- + generateSqueakSpur2PhaseIncrementalStackCog64VM + "No primitives since we can use those for the Cog VM" + ^VMMaker + generate: CoInterpreter + and: StackToRegisterMappingCogit + with: #(ObjectMemory Spur64BitCoMemoryManager + gcClass SpurIncremental2PhaseGarbageCollector + MULTIPLEBYTECODESETS true + TempVectReadBarrier true + bytecodeTableInitializer initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid) + to: self sourceTree, '/src/spur64.cog' + platformDir: self sourceTree, '/platforms' + including:#()! Item was changed: ----- Method: VMMaker class>>generateSqueakSpurIncrementalCog64VM (in category 'configurations') ----- generateSqueakSpurIncrementalCog64VM "No primitives since we can use those for the Cog VM" ^VMMaker generate: CoInterpreter and: StackToRegisterMappingCogit with: #(ObjectMemory Spur64BitCoMemoryManager MULTIPLEBYTECODESETS true TempVectReadBarrier true + gcClass SpurIncrementalGarbageCollector bytecodeTableInitializer initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid) to: self sourceTree, '/src/spur64.cog' platformDir: self sourceTree, '/platforms' including:#()! Item was changed: ----- Method: VMMaker class>>generateSqueakSpurIncrementalStack64VM (in category 'configurations') ----- generateSqueakSpurIncrementalStack64VM "No primitives since we can use those from the Cog VM" ^VMMaker generate: StackInterpreter with: #(ObjectMemory Spur64BitMemoryManager FailImbalancedPrimitives false MULTIPLEBYTECODESETS true + "TempVectReadBarrier true" - TempVectReadBarrier true gcClass SpurIncrementalGarbageCollector bytecodeTableInitializer initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid) to: self sourceTree, '/src/spur64.stack' platformDir: self sourceTree, '/platforms' including: #()! Item was changed: ----- Method: VMMaker>>buildCodeGeneratorForInterpreter:includeAPIMethods:initializeClasses: (in category 'generate sources') ----- buildCodeGeneratorForInterpreter: interpreterClass includeAPIMethods: getAPIMethods initializeClasses: initializeClasses "Answer the code generator for translating the interpreter." | cg interpreterClasses addedClasses | initializeClasses ifTrue: [interpreterClass initializeWithOptions: optionsDictionary. interpreterClass hasCogit ifTrue: [interpreterClass cogitClass initializeWithOptions: optionsDictionary]]. (cg := self createCodeGenerator) vmClass: interpreterClass. "Construct interpreterClasses as all classes from interpreterClass & objectMemoryClass up to VMClass in superclass to subclass order." interpreterClasses := OrderedCollection new. {interpreterClass. interpreterClass objectMemoryClass} do: [:vmClass| | theClass | theClass := vmClass theNonSimulatorClass. [theClass ~~ VMClass] whileTrue: [interpreterClasses addFirst: theClass. theClass := theClass superclass]]. interpreterClasses addFirst: VMClass; addAllLast: ((cg nonStructClassesForTranslationClasses: interpreterClasses) collect: [:vmClass| vmClass theNonSimulatorClass]). initializeClasses ifTrue: [interpreterClasses do: [:ic| (ic respondsTo: #initializeWithOptions:) ifTrue: [ic initializeWithOptions: interpreterClass initializationOptions] ifFalse: [ic initialize]]. (cg structClassesForTranslationClasses: interpreterClasses) do: [:structClass| structClass initialize]]. cg addStructClasses: (cg structClassesForTranslationClasses: interpreterClasses). addedClasses := IdentitySet new. interpreterClasses do: [:ic| (addedClasses ifAbsentAdd: ic) ifTrue: [cg addClass: ic]]. + + sharedResolver := cg polymorphicResolverForAdoption. getAPIMethods ifTrue: [interpreterClass cogitClass ifNotNil: [:cogitClass| cg includeAPIFrom: (self buildCodeGeneratorForCogit: cogitClass includeAPIMethods: false initializeClasses: false)]]. ^cg! Item was changed: ----- Method: VMMaker>>createCogitCodeGenerator (in category 'initialize') ----- createCogitCodeGenerator + + self assert: sharedResolver notNil. + ^CCodeGenerator new vmMaker: self; logger: logger; options: optionsDictionary; + adoptPolymorphicResolver: sharedResolver; yourself! Item was changed: ----- Method: VMMaker>>generateInterpreterFile (in category 'generate sources') ----- generateInterpreterFile "Translate the Smalltalk description of the virtual machine into C. If 'self doInlining' is true, small method bodies are inlined to reduce procedure call overhead. On the PPC, this results in a factor of three speedup with only 30% increase in code size. Subclasses can use specialised versions of CCodeGenerator and interpreterClass." | cg vmHeaderContents | cg := [self buildCodeGeneratorForInterpreter] on: Notification do: [:ex| ex tag == #getVMMaker ifTrue: [ex resume: self] ifFalse: [(ex respondsTo: #rearmHandlerDuring:) ifTrue: [ex rearmHandlerDuring: [ex pass]] ifFalse: [ex pass]]]. self reinitializeWordSizeFrom: cg. self interpreterClass additionalHeadersDo: [:headerName :headerContents| | filePath | filePath := self coreVMDirectory fullNameFor: headerName. (cg needToGenerateHeader: headerName file: filePath contents: headerContents) ifTrue: [cg storeHeaderOnFile: filePath contents: headerContents]]. self needsToRegenerateInterpreterFile ifFalse: [^nil]. cg inferTypesForImplicitlyTypedVariablesAndMethods. self interpreterClass preGenerationHook: cg. vmHeaderContents := cg vmHeaderContentsWithBytesPerWord: self wordSize. (cg needToGenerateHeader: self interpreterHeaderName file: self interpreterHeaderPath contents: vmHeaderContents) ifTrue: [cg storeHeaderOnFile: self interpreterHeaderPath contents: vmHeaderContents]. cg storeCodeOnFile: (self sourceFilePathFor: self interpreterClass sourceFileName) doInlining: self doInlining. self interpreterClass apiExportHeaderName ifNotNil: [cg storeAPIExportHeader: self interpreterClass apiExportHeaderName OnFile: (self sourceFilePathFor: self interpreterClass apiExportHeaderName) includePoolDefines: true]. (cg methodNamed: #interpret) ifNotNil: [self gnuifyInterpreterFile]. + self maybeGenerateVariableOrderFiles: cg. + + sharedResolver := cg polymorphicResolverForAdoption! - self maybeGenerateVariableOrderFiles: cg!

1 0

[OpenSmalltalk/opensmalltalk-vm] 52b15e: Accept the -eventtrace option on unix & windows.
by Eliot Miranda 08 Jun '23

08 Jun '23

Branch: refs/heads/virtend Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 52b15e11df163b2a32b50ce9fe72e9b9cf7fc959 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/52b15e11df163b2a32… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2023-06-08 (Thu, 08 Jun 2023) Changed paths: M platforms/unix/vm/sqUnixMain.c M platforms/win32/vm/sqWin32Main.c Log Message: ----------- Accept the -eventtrace option on unix & windows.

1 0

[OpenSmalltalk/opensmalltalk-vm] 5cc4fa: Accept the -eventtrace option on unix & windows.
by Eliot Miranda 08 Jun '23

08 Jun '23

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 5cc4fa5afc0120c48206c5668aacef7ae7307802 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/5cc4fa5afc0120c482… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2023-06-08 (Thu, 08 Jun 2023) Changed paths: M platforms/unix/vm/sqUnixMain.c M platforms/win32/vm/sqWin32Main.c Log Message: ----------- Accept the -eventtrace option on unix & windows.

1 0

[OpenSmalltalk/opensmalltalk-vm] 2a6169: Sort vm options printed for usage on osx & unix.
by Eliot Miranda 08 Jun '23

08 Jun '23

Branch: refs/heads/virtend Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 2a61697928987f1711ce2f13fd34833ed983f01b https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/2a61697928987f1711… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2023-06-08 (Thu, 08 Jun 2023) Changed paths: M building/macos32x86/common/Makefile.app M building/macos64ARMv8/common/Makefile.app M building/macos64x64/common/Makefile.app M platforms/Cross/vm/sq.h M platforms/iOS/vm/OSX/sqSqueakOSXApplication.m M platforms/unix/vm-display-X11/sqUnixX11.c M platforms/unix/vm/SqModule.h M platforms/unix/vm/sqUnixMain.c M platforms/win32/vm/sqWin32Main.c Log Message: ----------- Sort vm options printed for usage on osx & unix. Update the osx makefiles with phony targets to avoid creating empty files. Make accessing vm & image options more robust on win32.

1 0

[OpenSmalltalk/opensmalltalk-vm] f29cc4: Sort vm options printed for usage on osx & unix.
by Eliot Miranda 08 Jun '23

08 Jun '23

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: f29cc455874b3dbec8061fe997a67a4bc05135f8 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/f29cc455874b3dbec8… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2023-06-08 (Thu, 08 Jun 2023) Changed paths: M building/macos32x86/common/Makefile.app M building/macos64ARMv8/common/Makefile.app M building/macos64x64/common/Makefile.app M platforms/Cross/vm/sq.h M platforms/iOS/vm/OSX/sqSqueakOSXApplication.m M platforms/unix/vm-display-X11/sqUnixX11.c M platforms/unix/vm/SqModule.h M platforms/unix/vm/sqUnixMain.c M platforms/win32/vm/sqWin32Main.c Log Message: ----------- Sort vm options printed for usage on osx & unix. Update the osx makefiles with phony targets to avoid creating empty files. Make accessing vm & image options more robust on win32.

1 0

[OpenSmalltalk/opensmalltalk-vm] 6f5f2d: CogVM source as per VMMaker.oscog-eem.3329
by Eliot Miranda 07 Jun '23

07 Jun '23

Branch: refs/heads/virtend Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 6f5f2d2067c44ae07f8a1ffb30cf18331c505fb4 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/6f5f2d2067c44ae07f… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2023-06-07 (Wed, 07 Jun 2023) Changed paths: M src/spur32.cog.lowcode/cogit.h M src/spur32.cog.lowcode/cogitARMv5.c M src/spur32.cog.lowcode/cogitIA32.c M src/spur32.cog.newspeak/cogit.h M src/spur32.cog.newspeak/cogitARMv5.c M src/spur32.cog.newspeak/cogitIA32.c M src/spur32.cog.newspeak/cointerp.c M src/spur32.cog.newspeak/cointerp.h M src/spur32.cog.newspeak/gcc3x-cointerp.c M src/spur32.cog/cogit.h M src/spur32.cog/cogitARMv5.c M src/spur32.cog/cogitIA32.c M src/spur32.sista/cogit.h M src/spur32.sista/cogitARMv5.c M src/spur32.sista/cogitIA32.c M src/spur32.stack.newspeak/gcc3x-interp.c M src/spur32.stack.newspeak/interp.c M src/spur64.cog.lowcode/cogit.h M src/spur64.cog.lowcode/cogitARMv8.c M src/spur64.cog.lowcode/cogitX64SysV.c M src/spur64.cog.lowcode/cogitX64WIN64.c M src/spur64.cog.newspeak/cogit.h M src/spur64.cog.newspeak/cogitARMv8.c M src/spur64.cog.newspeak/cogitX64SysV.c M src/spur64.cog.newspeak/cogitX64WIN64.c M src/spur64.cog.newspeak/cointerp.c M src/spur64.cog.newspeak/cointerp.h M src/spur64.cog.newspeak/gcc3x-cointerp.c M src/spur64.cog/cogit.h M src/spur64.cog/cogitARMv8.c M src/spur64.cog/cogitX64SysV.c M src/spur64.cog/cogitX64WIN64.c M src/spur64.sista/cogit.h M src/spur64.sista/cogitARMv8.c M src/spur64.sista/cogitX64SysV.c M src/spur64.sista/cogitX64WIN64.c M src/spur64.stack.newspeak/gcc3x-interp.c M src/spur64.stack.newspeak/interp.c M src/v3.cog/cogit.h M src/v3.cog/cogitARMv5.c M src/v3.cog/cogitIA32.c Log Message: ----------- CogVM source as per VMMaker.oscog-eem.3329 Oops, sqWin32Backtrace.c expects cogCodebase to be in cogit.h. So put back the <api> pragma there-on and comment it. Generate the newspeak VMs while we're at it.

1 0

[OpenSmalltalk/opensmalltalk-vm] 63dbb0: CogVM source as per VMMaker.oscog-eem.3329
by Eliot Miranda 07 Jun '23

07 Jun '23

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 63dbb04c57f94279f37dab00f172d55f8f7eae7c https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/63dbb04c57f94279f3… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2023-06-07 (Wed, 07 Jun 2023) Changed paths: M src/spur32.cog.lowcode/cogit.h M src/spur32.cog.lowcode/cogitARMv5.c M src/spur32.cog.lowcode/cogitIA32.c M src/spur32.cog.newspeak/cogit.h M src/spur32.cog.newspeak/cogitARMv5.c M src/spur32.cog.newspeak/cogitIA32.c M src/spur32.cog.newspeak/cointerp.c M src/spur32.cog.newspeak/cointerp.h M src/spur32.cog.newspeak/gcc3x-cointerp.c M src/spur32.cog/cogit.h M src/spur32.cog/cogitARMv5.c M src/spur32.cog/cogitIA32.c M src/spur32.sista/cogit.h M src/spur32.sista/cogitARMv5.c M src/spur32.sista/cogitIA32.c M src/spur32.stack.newspeak/gcc3x-interp.c M src/spur32.stack.newspeak/interp.c M src/spur64.cog.lowcode/cogit.h M src/spur64.cog.lowcode/cogitARMv8.c M src/spur64.cog.lowcode/cogitX64SysV.c M src/spur64.cog.lowcode/cogitX64WIN64.c M src/spur64.cog.newspeak/cogit.h M src/spur64.cog.newspeak/cogitARMv8.c M src/spur64.cog.newspeak/cogitX64SysV.c M src/spur64.cog.newspeak/cogitX64WIN64.c M src/spur64.cog.newspeak/cointerp.c M src/spur64.cog.newspeak/cointerp.h M src/spur64.cog.newspeak/gcc3x-cointerp.c M src/spur64.cog/cogit.h M src/spur64.cog/cogitARMv8.c M src/spur64.cog/cogitX64SysV.c M src/spur64.cog/cogitX64WIN64.c M src/spur64.sista/cogit.h M src/spur64.sista/cogitARMv8.c M src/spur64.sista/cogitX64SysV.c M src/spur64.sista/cogitX64WIN64.c M src/spur64.stack.newspeak/gcc3x-interp.c M src/spur64.stack.newspeak/interp.c M src/v3.cog/cogit.h M src/v3.cog/cogitARMv5.c M src/v3.cog/cogitIA32.c Log Message: ----------- CogVM source as per VMMaker.oscog-eem.3329 Oops, sqWin32Backtrace.c expects cogCodebase to be in cogit.h. So put back the <api> pragma there-on and comment it. Generate the newspeak VMs while we're at it.

1 0

VM Maker: VMMaker.oscog-eem.3329.mcz
by commits＠source.squeak.org 07 Jun '23

07 Jun '23

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.3329.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.3329 Author: eem Time: 7 June 2023, 10:02:50.172462 am UUID: 31a93bfc-1d06-4008-9439-27c01b0644f9 Ancestors: VMMaker.oscog-eem.3328 Oops, sqWin32Backtrace.c expects cogCodebase to be in cogit.h. So put back the <api> pragma there-on and comment it. =============== Diff against VMMaker.oscog-eem.3328 =============== Item was changed: ----- Method: Cogit>>cogCodeBase (in category 'disassembly') ----- cogCodeBase + <api> "used e.g. in the platform's backtrace generators. Declared api to place it in cogit.h" - <public> "used e.g. in the platform's backtrace generators" ^codeBase!

1 0

[OpenSmalltalk/opensmalltalk-vm] 601baf: Type ioUTCMicroseconds et at consistently with sqV...
by Eliot Miranda 07 Jun '23

07 Jun '23

Branch: refs/heads/virtend Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 601baf2fde2d0e4b95bda0676e4e4c3296bade6b https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/601baf2fde2d0e4b95… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2023-06-06 (Tue, 06 Jun 2023) Changed paths: M platforms/Cross/vm/sq.h M platforms/Cross/vm/sqVirtualMachine.h M platforms/Mac OS/vm/sqMacTime.c M platforms/minheadless/common/sqaio.h M platforms/minheadless/unix/sqUnixHeartbeat.c M platforms/minheadless/windows/sqWin32Heartbeat.c M platforms/minheadless/windows/sqWin32Time.c M platforms/unix/vm/aio.c M platforms/unix/vm/sqUnixHeartbeat.c M platforms/unix/vm/sqUnixITimerHeartbeat.c M platforms/unix/vm/sqUnixITimerTickerHeartbeat.c M platforms/unix/vm/sqUnixMain.c M platforms/unix/vm/sqaio.h M platforms/win32/vm/sqWin32Heartbeat.c M platforms/win32/vm/sqWin32Time.c Log Message: ----------- Type ioUTCMicroseconds et at consistently with sqVirtualMachine's utcMicroseconds. Recent versions of clang protest, refusing to find type compatible unsigned long and unsigned long long on 64 bits. Alas this means that sqaio.h has to pull in sqMemoryAccess.h for the usqLong & sqLong definitions. But it's a price we have to pay.

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev June 2023