Vm-dev June 2018

vm-dev@lists.squeakfoundation.org

21 participants
83 discussions

[OpenSmalltalk/opensmalltalk-vm] b14623: BuildSqueakSpurTrunkVMMakerImage.st sort versions, ...
by GitHub 08 Jun '18

08 Jun '18

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: b14623bac08c1ceb0afe271d1335c7ab3ec57d39 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/b14623bac08c1ceb0a… Author: AlistairGrant <akgrant0710(a)gmail.com> Date: 2018-06-06 (Wed, 06 Jun 2018) Changed paths: M image/BuildSqueakSpurTrunkVMMakerImage.st Log Message: ----------- BuildSqueakSpurTrunkVMMakerImage.st sort versions, use FileAttributesPlugin.oscog BuildSqueakSpurTrunkVMMakerImage.st currently assumes that packages returned from a repository are sorted by version, however this doesn't appear to be true for smalltalkhub.com. - Sort packages by version to ensure the latest is used. - Load FileAttributesPlugin.oscog (which replaced FileAttributesPlugin) Commit: 0fe68bcb0ae6a0b4e4cf1307150720b5cfcd9836 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/0fe68bcb0ae6a0b4e4… Author: akgrant43 <akgrant(a)gmail.com> Date: 2018-06-08 (Fri, 08 Jun 2018) Changed paths: M image/BuildSqueakSpurTrunkVMMakerImage.st Log Message: ----------- Merge pull request #266 from akgrant43/buildvmmakerimage BuildSqueakSpurTrunkVMMakerImage.st sort versions, use FileAttributesPlugin.oscog. BuildSqueakSpurTrunkVMMakerImage.st currently assumes that packages returned from a repository are sorted by version, however this doesn't appear to be true for smalltalkhub.com. - Sort packages by version to ensure the latest is used. - Load FileAttributesPlugin.oscog (which replaced FileAttributesPlugin) With the original version, FileAttributesPlugin-AlistairGrant.12 would be loaded, while the current version is FileAttributesPlugin.oscog-AlistairGrant.28. Compare: https://github.com/OpenSmalltalk/opensmalltalk-vm/compare/4fc727f1f435...0f… **NOTE:** This service been marked for deprecation: https://developer.github.com/changes/2018-04-25-github-services-deprecation/ Functionality will be removed from GitHub.com on January 31st, 2019.

1 0

VM Maker: CogTools-eem.89.mcz
by commits＠source.squeak.org 08 Jun '18

08 Jun '18

Eliot Miranda uploaded a new version of CogTools to project VM Maker: http://source.squeak.org/VMMaker/CogTools-eem.89.mcz ==================== Summary ==================== Name: CogTools-eem.89 Author: eem Time: 7 June 2018, 4:24:39.450228 pm UUID: 08c05bc7-0618-4ae9-9d9c-cd76d1857cbd Ancestors: CogTools-eem.88 Eliminate a deprecation warning on Squeak. =============== Diff against CogTools-eem.88 =============== Item was changed: ----- Method: SqueakVMProfiler>>openInWindow (in category 'opening') ----- openInWindow "VMProfiler open" | window symbolListMorph labelsMorph buttons | (window := SystemWindow new) setProperty: #allowPaneSplitters toValue: false; model: self; setLabel: self class name; fillStyle: Color white; paneColor: Color white; color: Color white. (window respondsTo: #allowPaneSplitters:) ifTrue: [window allowPaneSplitters: false]. "Cope with Squeak 4.1 SystemWindow background color changes" window addMorph: (AlignmentMorph new color: Color white; yourself) frame: (0@0 corner: 1@1). symbolListMorph := PluggableListMorphOfManyAlt on: self list: #symbolList primarySelection: #symbolIndex changePrimarySelection: #toggleListIndex: listSelection: #symbolSelectionAt: changeListSelection: #symbolSelectionAt:put: getListElement: #listEntryForIndex: menu: #symbolListMenu:. + symbolListMorph hScrollBarPolicy: #whenNeeded. "buggy misnamed selector :)" - symbolListMorph showHScrollBarOnlyWhenNeeded: false. "buggy misnamed selector :)" labelsMorph := VMProfileGraphLabelMorph model: self font: self labelFont getLabels: #positionedLabels. expressionTextMorph := PluggableTextMorph on: self text: nil accept: nil readSelection: #selectionRange menu: #expressionTextMenu:. expressionTextMorph setProperty: #alwaysAccept toValue: true; askBeforeDiscardingEdits: false; setBalloonText: 'type an expression to profile here'. buttons := OrderedCollection new. window addMorph: symbolListMorph frame: (0@0 corner: 0.15@1); addMorph: (graph := VMProfilePlotMorph model: self) frame: (0.15@0 corner: 1.0(a)0.7); addMorph: labelsMorph frame: (0.15(a)0.7 corner: 1.0(a)0.85); "address boxes" addMorph: (self addressTextMorph:'Type the low address of the histogram here' get: #lowAddressText set: #lowAddressText:) frame: (0.16(a)0.86 corner: 0.27(a)0.91); addMorph: (self addressTextMorph:'Type the high address of the histogram here' get: #highAddressText set: #highAddressText:) frame: (0.88(a)0.86 corner: 0.99(a)0.91); addMorph: (self totalTextMorph: 'Shows the total number of samples' get: #totalText) frame: (0.88(a)0.92 corner: 0.99(a)0.98); "symbol list check-box filters" addMorph: (self checkMorph: 'show module symbols' get: #showingModules set: #toggleShowModules) frame: (0.16(a)0.915 corner: 0.175(a)0.93); addMorph: (buttons addLast: (StringMorph contents: 'modules')) frame: (0.19(a)0.915 corner: 0.27(a)0.93); addMorph: (self checkMorph: 'show extern symbols' get: #showingPublicFunctions set: #toggleShowPublicFunctions) frame: (0.16(a)0.935 corner: 0.175(a)0.95); addMorph: (buttons addLast: (StringMorph contents: 'externs')) frame: (0.19(a)0.935 corner: 0.27(a)0.95); addMorph: (self checkMorph: 'show static symbols' get: #showingPrivateFunctions set: #toggleShowPrivateFunctions) frame: (0.16(a)0.955 corner: 0.175(a)0.97); addMorph: (buttons addLast: (StringMorph contents: 'statics')) frame: (0.19(a)0.955 corner: 0.27(a)0.97); addMorph: (self checkMorph: 'show static symbols' get: #showingLabels set: #toggleShowLabels) frame: (0.16(a)0.975 corner: 0.175(a)0.99); addMorph: (buttons addLast: (StringMorph contents: 'labels')) frame: (0.19(a)0.975 corner: 0.27(a)0.99); "history buttons" addMorph: (self historyButtonMorph: #backwardsButton help: 'go back to previous selection' set: #regress enable: #hasHistory color: #hasHistoryColor) frame: (0.28(a)0.86 corner: 0.315(a)0.90); addMorph: (self historyButtonMorph: #forwardsButton help: 'go forward to next selection' set: #progress enable: #hasFuture color: #hasFutureColor) frame: (0.32(a)0.86 corner: 0.355(a)0.90); "profiling buttons" addMorph: (self buttonMorph: #drawButton help: 'plot the graph' set: #plotGraph enable: #notProfilingAndData color: #clearColor) frame: (0.37(a)0.86 corner: 0.45(a)0.91); addMorph: (self buttonMorph: #clearButton help: 'clear the histogram data' set: #clearProfile enable: #notProfiling color: #clearColor) frame: (0.46(a)0.86 corner: 0.54(a)0.91); addMorph: (self buttonMorph: #startButton help: 'start the profiler' set: #startProfiling enable: #notProfiling color: #profileColor) frame: (0.28(a)0.915 corner: 0.36(a)0.96); addMorph: (self buttonMorph: #stopButton help: 'stop the profiler' set: #stopProfiling enable: #profiling color: #stopColor) frame: (0.37(a)0.915 corner: 0.45(a)0.96); addMorph: (self buttonMorph: #profileExpressionButton help: 'compile and profile the expression to the right' set: #profileExpression enable: #notProfiling color: #profileColor) frame: (0.46(a)0.915 corner: 0.54(a)0.96); addMorph: expressionTextMorph frame: (0.55(a)0.86 corner: 0.87(a)0.98); addMorph: (self checkMorph: 'Run the full garbage collector prior to profiling' get: #gcPriorToProfile set: #toggleGcPriorToProfile) frame: (0.28(a)0.97 corner: 0.295(a)0.985); addMorph: (buttons addLast: (StringMorph contents: 'gc prior')) frame: (0.30(a)0.97 corner: 0.365(a)0.995); addMorph: (self checkMorph: 'Clear the profile prior to profiling' get: #clearPriorToProfile set: #toggleClearPriorToProfile) frame: (0.37(a)0.97 corner: 0.385(a)0.985); addMorph: (buttons addLast: (StringMorph contents: 'clear prior')) frame: (0.39(a)0.97 corner: 0.455(a)0.995); addMorph: (self checkMorph: 'Run the profiled expression in its own process' get: #forkProfile set: #toggleForkProfile) frame: (0.46(a)0.97 corner: 0.475(a)0.985); addMorph: (buttons addLast: (StringMorph contents: 'fork profile')) frame: (0.48(a)0.97 corner: 0.545(a)0.995). . "A Color transparent fillStyle used to be the default. What a pain that things change so radically from release to release!!" graph fillStyle: Color transparent. self updateButtons. "weird!!" buttons do: [:buttonMorph| buttonMorph color: Color black]. "otherwise labels don't show :(" window openInWorld. self toggleShowing: #module. ^window!

1 0

VM Maker: VMMaker.oscog-eem.2409.mcz
by commits＠source.squeak.org 08 Jun '18

08 Jun '18

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2409.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.2409 Author: eem Time: 7 June 2018, 4:02:08.947009 pm UUID: 679840b7-ac59-484f-a7aa-6bdb03ac1eb4 Ancestors: VMMaker.oscog-eem.2408 Fix static selector mapping in SpurCompactor; it needs to handle inheritance (SpurSelectiveCompactor inherits from SpurSweeper). Spur64BitMemoryManager>>bytesBigEnoughForPrevPointer: shouldn't use =/~= for robustness. =============== Diff against VMMaker.oscog-eem.2408 =============== Item was changed: ----- Method: Spur64BitMemoryManager>>bytesBigEnoughForPrevPointer: (in category 'free space') ----- bytesBigEnoughForPrevPointer: chunkBytes + "To have a prev pointer, which follows the next pointer, we need at least two slots." + ^chunkBytes > (self baseHeaderSize + self allocationUnit)! - ^ chunkBytes ~= (self baseHeaderSize + self allocationUnit)! Item was changed: ----- Method: SpurCompactor class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator "If subclasses are being used but are not the compactorClass itself + then statically resolve their api selectors." + (self inheritsFrom: SpurCompactor) ifTrue: "leave SpurCompactor methods alone" + [(SpurMemoryManager compactorClass includesBehavior: self) ifFalse: "only map methods not in the compactorClass" + [#(compact biasForGC biasForSnapshot remapObj: shouldRemapObj:) do: "map the public api methods only" + [:selectorToStaticallyResolve| + aCCodeGenerator + staticallyResolveMethodNamed: selectorToStaticallyResolve + forClass: self + to: (self staticallyResolvePolymorphicSelector: selectorToStaticallyResolve)]]]! - then staticvally resolve their api selectors." - ((self inheritsFrom: SpurCompactor) - and: [(InitializationOptions at: #compactorClass) ~= self name]) ifTrue: - [#(compact biasForGC biasForSnapshot remapObj: shouldRemapObj:) do: - [:selectorToStaticallyResolve| - aCCodeGenerator - staticallyResolveMethodNamed: selectorToStaticallyResolve - forClass: self - to: (self staticallyResolvePolymorphicSelector: selectorToStaticallyResolve)]]! Item was changed: ----- Method: SpurMemoryManager>>bytesBigEnoughForPrevPointer: (in category 'free space') ----- bytesBigEnoughForPrevPointer: chunkBytes + "Answer if chunkBytes (which includes an object header) has room enough for both + a next free chunk and a previous free chunk pointer. This is always true in 32-bits, + but in 64-bits requires at least 24 bytes." self subclassResponsibility!

1 0

VM Maker: VMMaker.oscog-eem.2408.mcz
by commits＠source.squeak.org 08 Jun '18

08 Jun '18

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2408.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.2408 Author: eem Time: 7 June 2018, 3:51:43.72542 pm UUID: a22d7480-0ba1-4f23-9116-32abed9941cd Ancestors: VMMaker.oscog-cb.2407 Initialization: Nuke the insane initializationOptions inst var in VMClass class and replace it by a simple class variable InitializationOptions. This avoids stale initializationOptions dictionaries during initialization. The exact symptom was the validation of options in VMClass class>>initializeMiscConstants; it wanted to check SpurmemoryManager's compactorClass, but since SpurMemoryManager's initialationOptions was stale it answered a bogus class. Grasshopper, enlightenment comes slowly to some. Consequently refactor ancilliaryClasses: to ancilliaryClasses (returning to an older style). =============== Diff against VMMaker.oscog-cb.2407 =============== Item was changed: ----- Method: CCodeGenerator>>initializerForInstVar:inStartClass: (in category 'inlining') ----- initializerForInstVar: varName inStartClass: aClass | allClasses sizeBefore | (aClass inheritsFrom: VMClass) ifFalse: [^false]. allClasses := (aClass withAllSuperclasses copyUpTo: VMClass) asSet. [sizeBefore := allClasses size. allClasses copy do: [:class| + class ancilliaryClasses do: - (class ancilliaryClasses: optionsDictionary) do: [:ancilliary| allClasses addAll: (ancilliary withAllSuperclasses copyUpTo: VMClass)]]. sizeBefore ~= allClasses size] whileTrue. allClasses do: [:class| (self initializerForInstVar: varName in: class) ifNotNil: [:initializer| ^initializer]]. ^nil! Item was changed: ----- Method: CCodeGenerator>>nonStructClassesForTranslationClasses: (in category 'utilities') ----- nonStructClassesForTranslationClasses: classes "Answer in superclass order (any superclass precedes any subclass) the ancilliaryClasses that are not struct classes for all the given classes." | nonStructClasses | nonStructClasses := OrderedCollection new. classes do: [:aTranslationClass| + ([aTranslationClass ancilliaryClasses] - ([aTranslationClass ancilliaryClasses: self options] on: MessageNotUnderstood do: [:ex| + ex message selector == #ancilliaryClasses - ex message selector == #ancilliaryClasses: ifTrue: [#()] ifFalse: [ex pass]]) do: [:class| (vmClass isNil or: [vmClass isAcceptableAncilliaryClass: class]) ifTrue: [(class isStructClass or: [(nonStructClasses includes: class) or: [classes includes: class]]) ifFalse: [nonStructClasses addLast: class]]]]. ^ChangeSet superclassOrder: nonStructClasses! Item was changed: ----- Method: CCodeGenerator>>structClassesForTranslationClasses: (in category 'utilities') ----- structClassesForTranslationClasses: classes "Answer in superclass order (any superclass precedes any subclass) the ancilliaryClasses that are struct classes for all the given classes." | theStructClasses | theStructClasses := OrderedCollection new. classes do: [:aTranslationClass| + ([aTranslationClass ancilliaryClasses] - ([aTranslationClass ancilliaryClasses: self options] on: MessageNotUnderstood do: [:ex| + ex message selector == #ancilliaryClasses - ex message selector == #ancilliaryClasses: ifTrue: [#()] ifFalse: [ex pass]]) do: [:class| (class isStructClass and: [(vmClass isNil or: [vmClass isAcceptableAncilliaryClass: class]) and: [(theStructClasses includes: class) not]]) ifTrue: [theStructClasses addLast: class]]]. ^ChangeSet superclassOrder: theStructClasses! Item was added: + ----- Method: CoInterpreter class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + "Answer any extra classes to be included in the translation." + ^(super ancilliaryClasses copyWithout: InterpreterStackPages), + { CoInterpreterStackPages. + CogBlockMethod. NSSendCache }, + ((Cogit ancilliaryClasses) select: [:class| class inheritsFrom: CogBlockMethod])! Item was removed: - ----- Method: CoInterpreter class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - "Answer any extra classes to be included in the translation." - ^((super ancilliaryClasses: options) copyWithout: InterpreterStackPages), - { CoInterpreterStackPages. - CogBlockMethod. NSSendCache }, - ((Cogit ancilliaryClasses: options) select: [:class| class inheritsFrom: CogBlockMethod])! Item was added: + ----- Method: CoInterpreterMT class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + "Answer any extra classes to be included in the translation." + ^super ancilliaryClasses, { CogThreadManager. CogVMThread }! Item was removed: - ----- Method: CoInterpreterMT class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - ^(super ancilliaryClasses: options), { CogThreadManager. CogVMThread }! Item was changed: ----- Method: CoInterpreterMT class>>initializeMiscConstants (in category 'initialization') ----- initializeMiscConstants super initializeMiscConstants. "N.B. some of these DisownFlags are replicated in platforms/Cross/vm/sqVirtualMachine.h. Hence they should always be initialized." DisownVMLockOutFullGC := 1. DisownVMForProcessorRelinquish := 2. + (InitializationOptions at: #COGMTVM ifAbsent: [false]) == false ifTrue: - (initializationOptions notNil - and: [(initializationOptions at: #COGMTVM ifAbsent: [false]) == false]) ifTrue: [^self]. COGMTVM := true. + ReturnToThreadSchedulingLoop := 2 "setjmp/longjmp code."! - ReturnToThreadSchedulingLoop := 2. "setjmp/longjmp code."! Item was changed: ----- Method: CogObjectRepresentationForSpur class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCodeGen "Deal wuth the fact that the number of trampolines depends on IMMUTABILITY and that IMMUTABILITY can be defined at compile time. Yes, this is a mess." | current values | self assert: (CogObjectRepresentationForSpur allSubclasses allSatisfy: [:sc| CogObjectRepresentationForSpur initializationOptions == sc initializationOptions]). + current := InitializationOptions at: #IMMUTABILITY ifAbsent: nil. - current := initializationOptions at: #IMMUTABILITY ifAbsent: nil. values := #(true false) collect: [:bool| + InitializationOptions at: #IMMUTABILITY put: bool. - initializationOptions at: #IMMUTABILITY put: bool. self cogitClass initializeNumTrampolines. (Cogit classPool at: #NumTrampolines) printString]. current + ifNil: [InitializationOptions removeKey: #IMMUTABILITY] + ifNotNil: [InitializationOptions at: #IMMUTABILITY put: current]. - ifNil: [initializationOptions removeKey: #IMMUTABILITY] - ifNotNil: [initializationOptions at: #IMMUTABILITY put: current]. values first ~= values last ifTrue: [aCodeGen addConstantForBinding: #NumTrampolines -> ('(IMMUTABILITY ? ' , values first , ' : ' , values last , ')')]. aCodeGen var: #ceStoreTrampolines declareC: ('#if IMMUTABILITY\sqInt ceStoreTrampolines[', NumStoreTrampolines printString, '];\#endif') withCRs! Item was changed: ----- Method: CogObjectRepresentationForSpur class>>initializeMiscConstants (in category 'initialization') ----- initializeMiscConstants + CheckRememberedInTrampoline := InitializationOptions at: #CheckRememberedInTrampoline ifAbsent: [false]! - CheckRememberedInTrampoline := initializationOptions at: #CheckRememberedInTrampoline ifAbsent: [false]! Item was changed: ----- Method: CogVMSimulator class>>initializeWithOptions: (in category 'initialization') ----- initializeWithOptions: optionsDictionary super initializeWithOptions: optionsDictionary. + ByteCountsPerMicrosecond := InitializationOptions - ByteCountsPerMicrosecond := initializationOptions at: #ByteCountsPerMicrosecond ifAbsent: [100]! Item was changed: ----- Method: CogVMSimulator class>>initializeWithOptions:objectMemoryClass: (in category 'class initialization') ----- initializeWithOptions: optionsDictionaryOrArray objectMemoryClass: objectMemoryClassOrNil "The relevant ObjectMemory, Interpreter and Cogit classes must be initialized in order. This happens notionally every time we start the simulator, but in fact happens when ever we instantiate a simulator." + InitializationOptions := optionsDictionaryOrArray isArray - initializationOptions := optionsDictionaryOrArray isArray ifTrue: [Dictionary newFromPairs: optionsDictionaryOrArray] ifFalse: [optionsDictionaryOrArray]. - (self allSuperclasses copyUpThrough: InterpreterPrimitives) do: - [:sc| sc initializationOptions: initializationOptions]. - (objectMemoryClassOrNil ifNil: [self objectMemoryClass]) + initializeWithOptions: InitializationOptions. - initializeWithOptions: initializationOptions. + self initializeWithOptions: InitializationOptions. - self initializeWithOptions: initializationOptions. (self cogitClass withAllSuperclasses copyUpTo: Cogit) reverseDo: + [:c| c initializeWithOptions: InitializationOptions]! - [:c| c initializeWithOptions: initializationOptions]! Item was changed: ----- Method: CogX64Compiler class>>initialize (in category 'class initialization') ----- initialize "Initialize various x64 instruction-related constants. [1] IA-32 Intel® Architecture Software Developer's Manual Volume 2A: Instruction Set Reference, A-M" "CogX64Compiler initialize" self ~~ CogX64Compiler ifTrue: [^self]. + InitializationOptions - initializationOptions ifNil: [ initializationOptions := Dictionary new ]. - initializationOptions at: #ABI ifPresent: [:abi| SysV := abi asUppercase ~= #WIN64 and: [abi asUppercase ~= #'_WIN64']] ifAbsent: [SysV := true]. "Default ABI; set to true for SysV, false for WIN64/_WIN64" RAX := 0. RCX := 1. "Were they completely mad or simply sadistic?" RDX := 2. RBX := 3. RSP := 4. RBP := 5. RSI := 6. RDI := 7. R8 := 8. R9 := 9. R10 := 10. R11 := 11. R12 := 12. R13 := 13. R14 := 14. R15 := 15. XMM0L := 0. XMM1L := 1. XMM2L := 2. XMM3L := 3. XMM4L := 4. XMM5L := 5. XMM6L := 6. XMM7L := 7. XMM8L := 8. XMM9L := 9. XMM10L := 10. XMM11L := 11. XMM12L := 12. XMM13L := 13. XMM14L := 14. XMM15L := 15. "Mod R/M Mod fields. See [1] Sec 2.4, 2.5 & 2.6 & Table 2-2" ModRegInd := 0. ModRegIndSIB := 4. ModRegIndDisp32 := 5. ModRegRegDisp8 := 1. ModRegRegDisp32 := 2. ModReg := 3. "SIB Scaled Index modes. See [1] Sec 2.4, 2.5 & 2.6 & Table 2-3" SIB1 := 0. SIB2 := 1. SIB4 := 2. SIB8 := 3. "Specific instructions" self initializeSpecificOpcodes: #(CDQ IDIVR IMULRR CPUID LFENCE MFENCE SFENCE LOCK CMPXCHGAwR CMPXCHGMwrR XCHGAwR XCHGMwrR XCHGRR CLD REP MOVSB MOVSQ) in: thisContext method! Item was changed: ----- Method: CogX64Compiler class>>moduleName (in category 'translation') ----- moduleName "CogAbstractInstruction subclasses collect: [:ea| ea moduleName]" + ^'cogit', self ISA, ((InitializationOptions at: #ABI ifAbsent: ['']) copyWithout: $_)! - ^'cogit', self ISA, ((initializationOptions at: #ABI ifAbsent: ['']) copyWithout: $_)! Item was changed: ----- Method: Cogit class>>activeCompilerClass (in category 'translation') ----- activeCompilerClass + ^InitializationOptions - ^initializationOptions at: #CogCompilerClass ifPresent: [:compilerClassName| Smalltalk classNamed: compilerClassName] ifAbsent: [(CogAbstractInstruction subclasses detect: [:compilerClass| + compilerClass ISA == (InitializationOptions at: #ISA ifAbsent: [#IA32])]) defaultCompilerClass]! - compilerClass ISA == (initializationOptions at: #ISA ifAbsent: [#IA32])]) defaultCompilerClass]! Item was added: + ----- Method: Cogit class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + "Answer any extra classes to be included in the translation." + ProcessorClass ifNil: + [Cogit initializeMiscConstants]. + ^(self activeCompilerClass withAllSuperclasses copyUpThrough: CogAbstractInstruction), + { CogMethodZone. + CogBlockStart. + CogBytecodeDescriptor. + CogBytecodeFixup. + CogPrimitiveDescriptor. + CogBlockMethod. + CogMethod. + self activeCompilerClass literalsManagerClass}, + ((InitializationOptions at: #NewspeakVM ifAbsent: [false]) + ifTrue: [{NewspeakCogMethod. NSSendCache}] + ifFalse: [#()]), + ((InitializationOptions at: #SistaVM ifAbsent: [false]) + ifTrue: [{SistaMethodZone}] + ifFalse: [#()])! Item was removed: - ----- Method: Cogit class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - ProcessorClass ifNil: - [Cogit initializeMiscConstants]. - ^(self activeCompilerClass withAllSuperclasses copyUpThrough: CogAbstractInstruction), - { CogMethodZone. - CogBlockStart. - CogBytecodeDescriptor. - CogBytecodeFixup. - CogPrimitiveDescriptor. - CogBlockMethod. - CogMethod. - self activeCompilerClass literalsManagerClass}, - ((options at: #NewspeakVM ifAbsent: [false]) - ifTrue: [{NewspeakCogMethod. NSSendCache}] - ifFalse: [#()]), - ((options at: #SistaVM ifAbsent: [false]) - ifTrue: [{SistaMethodZone}] - ifFalse: [#()])! Item was changed: ----- Method: Cogit class>>attemptToComputeInstVarNamesFor: (in category 'in-image compilation support') ----- attemptToComputeInstVarNamesFor: aCompiledMethod (aCompiledMethod methodClass instSize > 0) ifTrue: + [InitializationOptions - [initializationOptions at: #instVarNames put: (aCompiledMethod methodClass allInstVarNames)]! Item was changed: ----- Method: Cogit class>>attemptToComputeTempNamesFor: (in category 'in-image compilation support') ----- attemptToComputeTempNamesFor: aCompiledMethod (aCompiledMethod respondsTo: #tempNames) ifTrue: [| schematicTemps blocks | schematicTemps := aCompiledMethod methodNode schematicTempNamesString. blocks := aCompiledMethod embeddedBlockClosures. + InitializationOptions - initializationOptions at: #tempNames put: (Dictionary withAll: {aCompiledMethod initialPC -> (self decomposeSchematicTemps: (schematicTemps copyUpTo: $[))}, (blocks ifEmpty: [#()] ifNotEmpty: [aCompiledMethod embeddedBlockClosures with: (schematicTemps piecesCutWhere: [:a :b| b = $[]) allButFirst collect: [:c :s| c startpc -> (self decomposeSchematicTemps: (s copyWithoutAll: '[]'))]]))]! Item was changed: ----- Method: Cogit class>>generateCodeStringForCogitDotC (in category 'translation') ----- generateCodeStringForCogitDotC "Generate a skeletal cogit.c that includes the relevant cogitFOO.c for the appropriate subclasses of CogAbstractInstruction. self generateCodeStringForCogitDotC" | string insertPosition abis defaultDef | abis := OrderedCollection new. string := String streamContents: [:s| s nextPutAll: '/* Automatically generated by\ ' withCRs. s nextPutAll: (CCodeGenerator monticelloDescriptionFor: self). s cr; nextPutAll: ' */'. s cr; cr; nextPut: $#. insertPosition := s position. self translateableInstructionSubclassesAndInstalledOptionsDo: [:class | | abi | s nextPutAll: 'if '. + (abi := InitializationOptions at: #ABI ifAbsent: []) ifNotNil: - (abi := initializationOptions at: #ABI ifAbsent: []) ifNotNil: [s nextPutAll: (abis addLast: abi); nextPutAll: ' && (']. class identifyingPredefinedMacros do: [:predefinedMacro| s nextPutAll: 'defined('; nextPutAll: predefinedMacro; nextPut: $)] separatedBy: [s nextPutAll: ' || ']. abi ifNotNil: [s nextPut: $)]. s cr; cr; nextPutAll: '# include "'; nextPutAll: class moduleName; nextPutAll: '.c"'. s cr; cr; nextPutAll: '#el']. s nextPutAll: 'se'. #( 'As yet no Cogit implementation appears to exist for your platform.' 'Consider implementing it, starting by adding a subclass of CogAbstractInstruction.') do: [:msg| s cr; nextPutAll: '# error '; nextPutAll: msg]. s cr; nextPutAll: '#endif'; cr]. abis isEmpty ifTrue: [^string]. defaultDef := String streamContents: [:s| s nextPutAll: '#if !!'. abis do: [:abi| s nextPutAll: abi] separatedBy: [s nextPutAll: ' && !!']. s cr; nextPutAll: '# define '; nextPutAll: abis first; nextPutAll: ' 1'; cr. s nextPutAll: '#endif'; cr; cr]. ^string copyReplaceFrom: insertPosition to: insertPosition - 1 with: defaultDef! Item was changed: ----- Method: Cogit class>>initializeBytecodeTable (in category 'class initialization') ----- initializeBytecodeTable "SimpleStackBasedCogit initializeBytecodeTableWith: Dictionary new" "StackToRegisterMappingCogit initializeBytecodeTableWith: Dictionary new" | initializer | BytecodeSetHasDirectedSuperSend := BytecodeSetHasExtensions := false. + initializer := InitializationOptions - initializer := initializationOptions at: #bytecodeTableInitializer ifAbsent: [NewspeakVM ifTrue: [MULTIPLEBYTECODESETS ifTrue: [#initializeBytecodeTableForSqueakV3PlusClosuresNewspeakV4Hybrid] ifFalse: [#initializeBytecodeTableForNewspeakV4]] ifFalse: [MULTIPLEBYTECODESETS ifTrue: [#initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid] ifFalse: [#initializeBytecodeTableForSqueakV3PlusClosures]]]. "Now make sure all classes in the hierarchy have initialized to the same bytecode table." (self withAllSuperclasses copyUpTo: Cogit) reverseDo: "i.e. exclude Cogit" [:cogitClass| cogitClass perform: initializer]! Item was changed: ----- Method: Cogit class>>initializeMiscConstants (in category 'class initialization') ----- initializeMiscConstants super initializeMiscConstants. + Debug := InitializationOptions at: #Debug ifAbsent: [false]. + (InitializationOptions includesKey: #EagerInstructionDecoration) - Debug := initializationOptions at: #Debug ifAbsent: [false]. - (initializationOptions includesKey: #EagerInstructionDecoration) ifTrue: + [EagerInstructionDecoration := InitializationOptions at: #EagerInstructionDecoration] - [EagerInstructionDecoration := initializationOptions at: #EagerInstructionDecoration] ifFalse: [EagerInstructionDecoration ifNil: [EagerInstructionDecoration := false]]. "speeds up single stepping but could lose fidelity" + ProcessorClass := (InitializationOptions at: #ISA ifAbsentPut: [self objectMemoryClass defaultISA]) caseOf: { - ProcessorClass := (initializationOptions at: #ISA ifAbsentPut: [self objectMemoryClass defaultISA]) caseOf: { [#X64] -> [BochsX64Alien]. [#IA32] -> [BochsIA32Alien]. [#ARMv5] -> [GdbARMAlien]. [#MIPSEL] -> [MIPSELSimulator] }. CogCompilerClass := self activeCompilerClass. (CogCompilerClass withAllSuperclasses copyUpTo: CogAbstractInstruction) reverseDo: [:compilerClass| compilerClass initialize; initializeAbstractRegisters]. self objectMemoryClass objectRepresentationClass initializeMiscConstants. "Our criterion for which methods to JIT is literal count. The default value is 60 literals or less." + MaxLiteralCountForCompile := InitializationOptions at: #MaxLiteralCountForCompile ifAbsent: [60]. - MaxLiteralCountForCompile := initializationOptions at: #MaxLiteralCountForCompile ifAbsent: [60]. "we special-case 0, 1 & 2 argument sends, N is numArgs >= 3" NumSendTrampolines := 4. "Currently not even the ceImplicitReceiverTrampoline contains object references." NumObjRefsInRuntime := 0. "6 is a fine number for the max number of PCI entries. 8 is too large." MaxCPICCases := 6. "One variable defines whether in a block and whether in a vanilla or full block." InVanillaBlock := 1. InFullBlock := 2. NSCSelectorIndex := (NSSendCache instVarNames indexOf: #selector) - 1. NSCNumArgsIndex := (NSSendCache instVarNames indexOf: #numArgs) - 1. NSCClassTagIndex := (NSSendCache instVarNames indexOf: #classTag) - 1. NSCEnclosingObjectIndex := (NSSendCache instVarNames indexOf: #enclosingObject) - 1. NSCTargetIndex := (NSSendCache instVarNames indexOf: #target) - 1. NumOopsPerNSC := NSSendCache instVarNames size. "Max size to alloca when compiling. Mac OS X 10.6.8 segfaults approaching 8Mb. Linux 2.6.9 segfaults above 11Mb. WIndows XP segfaults approaching 2Mb." MaxStackAllocSize := 1024 * 1024 * 3 / 2 ! Item was changed: ----- Method: Cogit class>>initializeWithOptions: (in category 'class initialization') ----- initializeWithOptions: optionsDictionary - { self. CogMethodSurrogate. } , (self ancilliaryClasses: optionsDictionary) do: - [:aSuperclass| - aSuperclass withAllSubclasses do: - [:class| class initializationOptions: optionsDictionary]]. super initializeWithOptions: optionsDictionary. self initializeMiscConstants. "must precede other initialization." self initializeErrorCodes. self initializeCogMethodConstants. self initializeAnnotationConstants. self initializeBytecodeTable. self initializeNumTrampolines. self initializePrimitiveTable! Item was changed: ----- Method: Cogit class>>translateableInstructionSubclassesAndInstalledOptionsDo: (in category 'translation') ----- translateableInstructionSubclassesAndInstalledOptionsDo: aBlock "Evaluate aBlock with the translateable subclass and its options installed, being careful to clean-up afterwards." CogAbstractInstruction translateableSubclassesAndOptions do: [:pair| [:class :options| | toRemove | toRemove := Set new. options pairsDo: [:key :value| + (InitializationOptions includesKey: key) ifFalse: - (initializationOptions includesKey: key) ifFalse: [toRemove add: key]. + InitializationOptions at: key put: value]. - initializationOptions at: key put: value]. aBlock value: class. + toRemove do: [:key| InitializationOptions removeKey: key]] - toRemove do: [:key| initializationOptions removeKey: key]] valueWithArguments: pair]! Item was added: + ----- Method: IA32ABIPlugin class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + "Answer any extra classes to be included in the translation." + ^{ VMCallbackContext. VMCallbackReturnValue }! Item was removed: - ----- Method: IA32ABIPlugin class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - ^{ VMCallbackContext. VMCallbackReturnValue }! Item was changed: ----- Method: Interpreter class>>initializeMiscConstants (in category 'initialization') ----- initializeMiscConstants super initializeMiscConstants. + DoBalanceChecks := InitializationOptions at: #DoBalanceChecks ifAbsent: [false]. "generate stack balance checks" - DoBalanceChecks := initializationOptions at: #DoBalanceChecks ifAbsent: [false]. "generate stack balance checks" SemaphoresToSignalSize := 500. PrimitiveExternalCallIndex := 117. "Primitive index for #primitiveExternalCall" MillisecondClockMask := 16r1FFFFFFF. "Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)" MaxExternalPrimitiveTableSize := 4096. "entries" MaxJumpBuf := 32. "max. callback depth"! Item was changed: ----- Method: RiscOSVMMaker>>needsToRegenerateInterpreterFile (in category 'initialize') ----- needsToRegenerateInterpreterFile "Check the timestamp for the relevant classes and then the timestamp for the main source file (e.g. interp.c) if it already exists. Answer if the file needs regenerating." | classes tStamp fstat | classes := self interpreterClass withAllSuperclasses copyUpTo: VMClass. self interpreterClass objectMemoryClass ifNotNil: [:objectMemoryClass| classes addAllLast: (objectMemoryClass withAllSuperclasses copyUpTo: VMClass)]. classes copy do: + [:class| classes addAllLast: class ancilliaryClasses]. - [:class| classes addAllLast: (class ancilliaryClasses: self options)]. tStamp := classes inject: 0 into: [:tS :cl| tS max: cl timeStamp]. "don't translate if the file is newer than my timeStamp" "RiscOS keeps the interp file in a 'c' subdirectory of coreVMDirectory" (self coreVMDirectory directoryExists: 'c') ifFalse:[^true]. fstat := (self coreVMDirectory directoryNamed: 'c') entryAt: self interpreterFilename ifAbsent:[nil]. fstat ifNotNil:[tStamp < fstat modificationTime ifTrue:[^false]]. ^true ! Item was added: + ----- Method: SimpleStackBasedCogit class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + "Answer any extra classes to be included in the translation." + ^super ancilliaryClasses, (self objectRepresentationClass withAllSuperclasses copyUpThrough: CogObjectRepresentation) reverse! Item was removed: - ----- Method: SimpleStackBasedCogit class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - initializationOptions ifNil: - [initializationOptions := options]. - ^(super ancilliaryClasses: options), (self objectRepresentationClass withAllSuperclasses copyUpThrough: CogObjectRepresentation) reverse! Item was changed: ----- Method: SimpleStackBasedCogit class>>initializeBytecodeTableForSqueakV3PlusClosures (in category 'class initialization') ----- initializeBytecodeTableForSqueakV3PlusClosures "SimpleStackBasedCogit initializeBytecodeTableForSqueakV3PlusClosures" FirstSpecialSelector := 176. NumSpecialSelectors := 32. self flag: 'Special selector send class must be inlined to agree with the interpreter, which inlines class. If class is sent to e.g. a general instance of ProtoObject then unless class is inlined there will be an MNU. It must be that the Cointerpreter and Cogit have identical semantics. We get away with not hardwiring the other special selectors either because in the Cointerpreter they are not inlined or because they are inlined only to instances of classes for which there will always be a method.'. self generatorTableFrom: #( (1 0 15 genPushReceiverVariableBytecode isInstVarRef) (1 16 31 genPushTemporaryVariableBytecode) (1 32 63 genPushLiteralConstantBytecode needsFrameNever: 1) (1 64 95 genPushLiteralVariableBytecode needsFrameNever: 1) (1 96 103 genStoreAndPopReceiverVariableBytecode isInstVarRef isMappedIfImmutability needsFrameIfImmutability: -1) (1 104 111 genStoreAndPopTemporaryVariableBytecode) (1 112 112 genPushReceiverBytecode) (1 113 113 genPushConstantTrueBytecode needsFrameNever: 1) (1 114 114 genPushConstantFalseBytecode needsFrameNever: 1) (1 115 115 genPushConstantNilBytecode needsFrameNever: 1) (1 116 119 genPushQuickIntegerConstantBytecode needsFrameNever: 1) "method returns in blocks need a frame because of nonlocalReturn:through:" (1 120 120 genReturnReceiver return needsFrameIfInBlock: isMappedInBlock 0) (1 121 121 genReturnTrue return needsFrameIfInBlock: isMappedInBlock 0) (1 122 122 genReturnFalse return needsFrameIfInBlock: isMappedInBlock 0) (1 123 123 genReturnNil return needsFrameIfInBlock: isMappedInBlock 0) (1 124 124 genReturnTopFromMethod return needsFrameIfInBlock: isMappedInBlock -1) (1 125 125 genReturnTopFromBlock return needsFrameNever: -1) (1 126 127 unknownBytecode) (2 128 128 extendedPushBytecode isInstVarRef) "well, maybe inst var ref" (2 129 129 extendedStoreBytecode isInstVarRef isMappedIfImmutability) "well, maybe inst var ref" (2 130 130 extendedStoreAndPopBytecode isInstVarRef isMappedIfImmutability) "well, maybe inst var ref" (2 131 131 genExtendedSendBytecode isMapped) (3 132 132 doubleExtendedDoAnythingBytecode isInstVarRef isMapped) "well, maybe inst var ref" (2 133 133 genExtendedSuperBytecode isMapped) (2 134 134 genSecondExtendedSendBytecode isMapped) (1 135 135 genPopStackBytecode needsFrameNever: -1) (1 136 136 duplicateTopBytecode needsFrameNever: 1) (1 137 137 genPushActiveContextBytecode) (2 138 138 genPushNewArrayBytecode)), + ((InitializationOptions at: #SpurObjectMemory ifAbsent: [false]) - ((initializationOptions at: #SpurObjectMemory ifAbsent: [false]) ifTrue: [#((3 139 139 genCallPrimitiveBytecode))] ifFalse: [#((1 139 139 unknownBytecode))]), #( (3 140 140 genPushRemoteTempLongBytecode) (3 141 141 genStoreRemoteTempLongBytecode) (3 142 142 genStoreAndPopRemoteTempLongBytecode) (4 143 143 genPushClosureCopyCopiedValuesBytecode block v3:Block:Code:Size:) (1 144 151 genShortUnconditionalJump branch v3:ShortForward:Branch:Distance:) (1 152 159 genShortJumpIfFalse branch isBranchFalse isMapped "because of mustBeBoolean" v3:ShortForward:Branch:Distance:) (2 160 163 genLongUnconditionalBackwardJump branch isMapped "because of interrupt check" v3:Long:Branch:Distance:) (2 164 167 genLongUnconditionalForwardJump branch v3:Long:Branch:Distance:) (2 168 171 genLongJumpIfTrue branch isBranchTrue isMapped "because of mustBeBoolean" v3:LongForward:Branch:Distance:) (2 172 175 genLongJumpIfFalse branch isBranchFalse isMapped "because of mustBeBoolean" v3:LongForward:Branch:Distance:) (1 176 197 genSpecialSelectorSend isMapped) (1 198 198 genSpecialSelectorEqualsEquals needsFrameNever: notMapped -1) "not mapped because it is directly inlined (for now)" (1 199 199 genSpecialSelectorClass needsFrameNever: notMapped 0) "not mapped because it is directly inlined (for now)" (1 200 200 genSpecialSelectorNotEqualsEquals needsFrameNever: notMapped -1) "not mapped because it is directly inlined (for now)" (1 201 207 genSpecialSelectorSend isMapped) (1 208 223 genSendLiteralSelector0ArgsBytecode isMapped) (1 224 239 genSendLiteralSelector1ArgBytecode isMapped) (1 240 255 genSendLiteralSelector2ArgsBytecode isMapped))! Item was added: + ----- Method: SistaCogit class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + "Answer any extra classes to be included in the translation." + ^super ancilliaryClasses copyWith: SistaCogMethod! Item was removed: - ----- Method: SistaCogit class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - ^(super ancilliaryClasses: options) copyWith: SistaCogMethod! Item was added: + ----- Method: SistaCogitClone class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + "Answer any extra classes to be included in the translation." + ^super ancilliaryClasses copyWith: SistaCogMethod! Item was removed: - ----- Method: SistaCogitClone class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - ^(super ancilliaryClasses: options) copyWith: SistaCogMethod! Item was changed: ----- Method: SpurCompactor class>>classesForTranslation (in category 'translation') ----- classesForTranslation + "Usually we want to add the SpurCompactor first, followed by the subclass. + SpurHybridCompactor is more complicated." ^(self withAllSuperclasses copyUpThrough: SpurCompactor) reverse! Item was changed: ----- Method: SpurCompactor class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator "If subclasses are being used but are not the compactorClass itself then staticvally resolve their api selectors." ((self inheritsFrom: SpurCompactor) + and: [(InitializationOptions at: #compactorClass) ~= self name]) ifTrue: - and: [(initializationOptions at: #compactorClass) ~= self name]) ifTrue: [#(compact biasForGC biasForSnapshot remapObj: shouldRemapObj:) do: [:selectorToStaticallyResolve| aCCodeGenerator staticallyResolveMethodNamed: selectorToStaticallyResolve forClass: self to: (self staticallyResolvePolymorphicSelector: selectorToStaticallyResolve)]]! Item was removed: - ----- Method: SpurHybridCompactor class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - "Answer any extra classes to be included in the translation." - ^{ SpurPlanningCompactor. - SpurSelectiveCompactor. - SpurSweeper }! Item was changed: ----- Method: SpurHybridCompactor class>>classesForTranslation (in category 'translation') ----- classesForTranslation + ^{ SpurPlanningCompactor. + SpurSelectiveCompactor. + SpurSweeper }, super classesForTranslation! - ^(self ancilliaryClasses: nil), super classesForTranslation! Item was added: + ----- Method: SpurMemoryManager class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + "Answer any extra classes to be included in the translation." + ^{ SpurGenerationScavenger. SpurScavengeLogRecord. SpurSegmentManager. SpurSegmentInfo }, + self compactorClass classesForTranslation, + SpurNewSpaceSpace withAllSubclasses + + ! Item was removed: - ----- Method: SpurMemoryManager class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - initializationOptions ifNil: [initializationOptions := options]. - ^{ SpurGenerationScavenger. SpurScavengeLogRecord. SpurSegmentManager. SpurSegmentInfo }, - self compactorClass classesForTranslation, - SpurNewSpaceSpace withAllSubclasses - - ! Item was changed: ----- Method: SpurMemoryManager class>>compactorClass (in category 'accessing class hierarchy') ----- compactorClass "Answer the compaction algorithm to use." + ^Smalltalk classNamed: (InitializationOptions at: #compactorClass ifAbsent: [#SpurPlanningCompactor])! - ^Smalltalk classNamed: (initializationOptions at: #compactorClass ifAbsent: [#SpurPlanningCompactor])! Item was changed: ----- Method: SpurMemoryManager class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator self declareCAsOop: #( memory freeStart scavengeThreshold newSpaceStart newSpaceLimit pastSpaceStart + lowSpaceThreshold freeOldSpaceStart oldSpaceStart endOfMemory) - lowSpaceThreshold freeOldSpaceStart oldSpaceStart endOfMemory firstFreeChunk lastFreeChunk) in: aCCodeGenerator. self declareCAsUSqLong: (self allInstVarNames select: [:ivn| ivn endsWith: 'Usecs']), #(statAllocatedBytes) in: aCCodeGenerator. aCCodeGenerator 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, ' */]'! Item was changed: ----- Method: SpurMemoryManager class>>initializeWithOptions: (in category 'class initialization') ----- initializeWithOptions: optionsDictionary "SpurMemoryManager initializeWithOptions: Dictionary new" - {self}, (self ancilliaryClasses: optionsDictionary) do: - [:aSuperclass| - aSuperclass withAllSubclasses do: - [:class| class initializationOptions: optionsDictionary]]. - super initializeWithOptions: optionsDictionary. + InitializationOptions - initializationOptions at: #Spur32BitMemoryManager ifAbsentPut: false; at: #Spur64BitMemoryManager ifAbsentPut: false. self initialize. self initBytesPerWord: (self == SpurMemoryManager ifTrue: [optionsDictionary at: #BytesPerWord ifAbsent: [4]] ifFalse: [self wordSize]). self initializeObjectHeaderConstants. "Initializes BaseHeaderSize so do early" self initializeSpurObjectRepresentationConstants. self initializeSpecialObjectIndices. self initializeCompactClassIndices. self initializePrimitiveErrorCodes. SpurGenerationScavenger initialize! Item was added: + ----- Method: StackInterpreter class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + "Answer any extra classes to be included in the translation." + ^{ self objectMemoryClass. + VMCallbackContext. + CogStackPages. + InterpreterStackPages. + CogStackPage }! Item was removed: - ----- Method: StackInterpreter class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - "Answer any extra classes to be included in the translation." - ^{ self objectMemoryClass. - VMCallbackContext. - CogStackPages. - InterpreterStackPages. - CogStackPage }! Item was changed: ----- Method: StackInterpreter class>>initializeBytecodeTable (in category 'initialization') ----- initializeBytecodeTable "StackInterpreter initializeBytecodeTable" + VMBytecodeConstants falsifyBytecodeSetFlags: InitializationOptions. - VMBytecodeConstants falsifyBytecodeSetFlags: initializationOptions. BytecodeSetHasDirectedSuperSend := false. + (InitializationOptions at: #bytecodeTableInitializer ifAbsent: nil) ifNotNil: - (initializationOptions at: #bytecodeTableInitializer ifAbsent: nil) ifNotNil: [:initalizer| ^self perform: initalizer]. NewspeakVM ifTrue: [^MULTIPLEBYTECODESETS ifTrue: [self initializeBytecodeTableForSqueakV3PlusClosuresNewspeakV4Hybrid] ifFalse: [self initializeBytecodeTableForNewspeakV4]]. ^MULTIPLEBYTECODESETS ifTrue: [self initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid] ifFalse: [self initializeBytecodeTableForSqueakV3PlusClosures]! Item was changed: ----- Method: StackInterpreter class>>initializeBytecodeTableForNewspeakV4 (in category 'initialization') ----- initializeBytecodeTableForNewspeakV4 "StackInterpreter initializeBytecodeTableForNewspeakV4" "Note: This table will be used to generate a C switch statement." + InitializationOptions at: #NewsqueakV4BytecodeSet put: (NewsqueakV4BytecodeSet := true). - initializationOptions at: #NewsqueakV4BytecodeSet put: (NewsqueakV4BytecodeSet := true). BytecodeTable := Array new: 256. BytecodeEncoderClassName := #EncoderForNewsqueakV4. BytecodeSetHasExtensions := true. LongStoreBytecode := 234. self table: BytecodeTable from: #( "1 byte bytecodes" ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushLiteralVariable16CasesBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 75 pushTemporaryVariableBytecode) ( 76 pushReceiverBytecode) ( 77 extPushPseudoVariableOrOuterBytecode) ( 78 pushConstantZeroBytecode) ( 79 pushConstantOneBytecode) ( 80 bytecodePrimAdd) ( 81 bytecodePrimSubtract) ( 82 bytecodePrimLessThanV4) "for booleanCheatV4:" ( 83 bytecodePrimGreaterThanV4) "for booleanCheatV4:" ( 84 bytecodePrimLessOrEqualV4) "for booleanCheatV4:" ( 85 bytecodePrimGreaterOrEqualV4) "for booleanCheatV4:" ( 86 bytecodePrimEqualV4) "for booleanCheatV4:" ( 87 bytecodePrimNotEqualV4) "for booleanCheatV4:" ( 88 bytecodePrimMultiply) ( 89 bytecodePrimDivide) ( 90 bytecodePrimMod) ( 91 bytecodePrimMakePoint) ( 92 bytecodePrimBitShift) ( 93 bytecodePrimDiv) ( 94 bytecodePrimBitAnd) ( 95 bytecodePrimBitOr) ( 96 bytecodePrimAt) ( 97 bytecodePrimAtPut) ( 98 bytecodePrimSize) ( 99 bytecodePrimNext) (100 bytecodePrimNextPut) (101 bytecodePrimAtEnd) (102 bytecodePrimIdenticalV4) "for booleanCheatV4:" (103 bytecodePrimClass) (104 bytecodePrimNotIdenticalV4) "was blockCopy:" (105 bytecodePrimValue) (106 bytecodePrimValueWithArg) (107 bytecodePrimDo) (108 bytecodePrimNew) (109 bytecodePrimNewWithArg) (110 bytecodePrimPointX) (111 bytecodePrimPointY) (112 127 sendLiteralSelector0ArgsBytecode) (128 143 sendLiteralSelector1ArgBytecode) (144 159 sendLiteralSelector2ArgsBytecode) (160 175 sendAbsentImplicit0ArgsBytecode) (176 183 storeAndPopReceiverVariableBytecode) (184 191 storeAndPopTemporaryVariableBytecode) (192 199 shortUnconditionalJump) (200 207 shortConditionalJumpTrue) (208 215 shortConditionalJumpFalse) (216 returnReceiver) (217 returnTopFromMethod) (218 extReturnTopFromBlock) (219 duplicateTopBytecode) (220 popStackBytecode) (221 extNopBytecode) (222 223 unknownBytecode) "2 byte bytecodes" (224 extABytecode) (225 extBBytecode) (226 extPushReceiverVariableBytecode) (227 extPushLiteralVariableBytecode) (228 extPushLiteralBytecode) (229 extPushIntegerBytecode) (230 longPushTemporaryVariableBytecode) (231 pushNewArrayBytecode) (232 extStoreReceiverVariableBytecode) (233 extStoreLiteralVariableBytecode) (234 longStoreTemporaryVariableBytecode) (235 extStoreAndPopReceiverVariableBytecode) (236 extStoreAndPopLiteralVariableBytecode) (237 longStoreAndPopTemporaryVariableBytecode) (238 extSendBytecode) (239 extSendSuperBytecode) (240 extSendAbsentImplicitBytecode) (241 extSendAbsentDynamicSuperBytecode) (242 extUnconditionalJump) (243 extJumpIfTrue) (244 extJumpIfFalse) (245 extSendAbsentSelfBytecode) (246 248 unknownBytecode) "3 byte bytecodes" (249 callPrimitiveBytecode) (250 pushRemoteTempLongBytecode) (251 storeRemoteTempLongBytecode) (252 storeAndPopRemoteTempLongBytecode) (253 extPushClosureBytecode) (254 extSendAbsentOuterBytecode) (255 unknownBytecode) )! Item was changed: ----- Method: StackInterpreter class>>initializeBytecodeTableForSistaV1 (in category 'initialization') ----- initializeBytecodeTableForSistaV1 "See e.g. the cass comment for EncoderForSistaV1" "StackInterpreter initializeBytecodeTableForSistaV1" "Note: This table will be used to generate a C switch statement." + InitializationOptions at: #SistaV1BytecodeSet put: (SistaV1BytecodeSet := true). - initializationOptions at: #SistaV1BytecodeSet put: (SistaV1BytecodeSet := true). BytecodeTable := Array new: 256. BytecodeEncoderClassName := #EncoderForSistaV1. BytecodeSetHasDirectedSuperSend := true. BytecodeSetHasExtensions := true. LongStoreBytecode := 245. self table: BytecodeTable from: #( "1 byte bytecodes" ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushLiteralVariable16CasesBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 75 pushTemporaryVariableBytecode) ( 76 pushReceiverBytecode) ( 77 pushConstantTrueBytecode) ( 78 pushConstantFalseBytecode) ( 79 pushConstantNilBytecode) ( 80 pushConstantZeroBytecode) ( 81 pushConstantOneBytecode) ( 82 extPushPseudoVariable) ( 83 duplicateTopBytecode) ( 84 87 unknownBytecode) ( 88 returnReceiver) ( 89 returnTrue) ( 90 returnFalse) ( 91 returnNil) ( 92 returnTopFromMethod) ( 93 returnNilFromBlock) ( 94 returnTopFromBlock) ( 95 extNopBytecode) ( 96 bytecodePrimAdd) ( 97 bytecodePrimSubtract) ( 98 bytecodePrimLessThanSistaV1) "for booleanCheatSistaV1:" ( 99 bytecodePrimGreaterThanSistaV1) "for booleanCheatSistaV1:" (100 bytecodePrimLessOrEqualSistaV1) "for booleanCheatSistaV1:" (101 bytecodePrimGreaterOrEqualSistaV1) "for booleanCheatSistaV1:" (102 bytecodePrimEqualSistaV1) "for booleanCheatSistaV1:" (103 bytecodePrimNotEqualSistaV1) "for booleanCheatSistaV1:" (104 bytecodePrimMultiply) (105 bytecodePrimDivide) (106 bytecodePrimMod) (107 bytecodePrimMakePoint) (108 bytecodePrimBitShift) (109 bytecodePrimDiv) (110 bytecodePrimBitAnd) (111 bytecodePrimBitOr) (112 bytecodePrimAt) (113 bytecodePrimAtPut) (114 bytecodePrimSize) (115 bytecodePrimNext) "i.e. a 0 arg special selector" (116 bytecodePrimNextPut) "i.e. a 1 arg special selector" (117 bytecodePrimAtEnd) (118 bytecodePrimIdenticalSistaV1) "for booleanCheatSistaV1:" (119 bytecodePrimClass) (120 bytecodePrimNotIdenticalSistaV1) "was blockCopy:" (121 bytecodePrimValue) (122 bytecodePrimValueWithArg) (123 bytecodePrimDo) "i.e. a 1 arg special selector" (124 bytecodePrimNew) "i.e. a 0 arg special selector" (125 bytecodePrimNewWithArg) "i.e. a 1 arg special selector" (126 bytecodePrimPointX) "i.e. a 0 arg special selector" (127 bytecodePrimPointY) "i.e. a 0 arg special selector" (128 143 sendLiteralSelector0ArgsBytecode) (144 159 sendLiteralSelector1ArgBytecode) (160 175 sendLiteralSelector2ArgsBytecode) (176 183 shortUnconditionalJump) (184 191 shortConditionalJumpTrue) (192 199 shortConditionalJumpFalse) (200 207 storeAndPopReceiverVariableBytecode) (208 215 storeAndPopTemporaryVariableBytecode) (216 popStackBytecode) (217 unconditionnalTrapBytecode) (218 223 unknownBytecode) "2 byte bytecodes" (224 extABytecode) (225 extBBytecode) (226 extPushReceiverVariableBytecode) (227 extPushLiteralVariableBytecode) (228 extPushLiteralBytecode) (229 longPushTemporaryVariableBytecode) (230 unknownBytecode) (231 pushNewArrayBytecode) (232 extPushIntegerBytecode) (233 extPushCharacterBytecode) (234 extSendBytecode) (235 extSendSuperBytecode) (236 callMappedInlinedPrimitive) (237 extUnconditionalJump) (238 extJumpIfTrue) (239 extJumpIfFalse) (240 extStoreAndPopReceiverVariableBytecode) (241 extStoreAndPopLiteralVariableBytecode) (242 longStoreAndPopTemporaryVariableBytecode) (243 extStoreReceiverVariableBytecode) (244 extStoreLiteralVariableBytecode) (245 longStoreTemporaryVariableBytecode) (246 247 unknownBytecode) "3 byte bytecodes" (248 callPrimitiveBytecode) (249 extPushFullClosureBytecode) (250 extPushClosureBytecode) (251 pushRemoteTempLongBytecode) (252 storeRemoteTempLongBytecode) (253 storeAndPopRemoteTempLongBytecode) (254 255 unknownBytecode) )! Item was changed: ----- Method: StackInterpreter class>>initializeBytecodeTableForSqueakV3PlusClosures (in category 'initialization') ----- initializeBytecodeTableForSqueakV3PlusClosures "StackInterpreter initializeBytecodeTableForSqueakV3PlusClosures" "Note: This table will be used to generate a C switch statement." + InitializationOptions at: #SqueakV3PlusClosuresBytecodeSet put: (SqueakV3PlusClosuresBytecodeSet := true). - initializationOptions at: #SqueakV3PlusClosuresBytecodeSet put: (SqueakV3PlusClosuresBytecodeSet := true). BytecodeTable := Array new: 256. BytecodeEncoderClassName := #EncoderForV3PlusClosures. LongStoreBytecode := 129. BytecodeSetHasExtensions := false. self table: BytecodeTable from: #( ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushTemporaryVariableBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 95 pushLiteralVariableBytecode) ( 96 103 storeAndPopReceiverVariableBytecode) (104 111 storeAndPopTemporaryVariableBytecode) (112 pushReceiverBytecode) (113 pushConstantTrueBytecode) (114 pushConstantFalseBytecode) (115 pushConstantNilBytecode) (116 pushConstantMinusOneBytecode) (117 pushConstantZeroBytecode) (118 pushConstantOneBytecode) (119 pushConstantTwoBytecode) (120 returnReceiver) (121 returnTrue) (122 returnFalse) (123 returnNil) (124 returnTopFromMethod) (125 returnTopFromBlock) (126 127 unknownBytecode) (128 extendedPushBytecode) (129 extendedStoreBytecode) (130 extendedStoreAndPopBytecode) (131 singleExtendedSendBytecode) (132 doubleExtendedDoAnythingBytecode) (133 singleExtendedSuperBytecode) (134 secondExtendedSendBytecode) (135 popStackBytecode) (136 duplicateTopBytecode) (137 pushActiveContextBytecode) (138 pushNewArrayBytecode)), + ((InitializationOptions at: #SpurObjectMemory ifAbsent: [false]) - ((initializationOptions at: #SpurObjectMemory ifAbsent: [false]) ifTrue: [#((139 callPrimitiveBytecode))] "V3PlusClosures on Spur" ifFalse: [#((139 unknownBytecode))]), "V3PlusClosures on V3" #( (140 pushRemoteTempLongBytecode) (141 storeRemoteTempLongBytecode) (142 storeAndPopRemoteTempLongBytecode) (143 pushClosureCopyCopiedValuesBytecode) (144 151 shortUnconditionalJump) (152 159 shortConditionalJumpFalse) (160 167 longUnconditionalJump) (168 171 longJumpIfTrue) (172 175 longJumpIfFalse) "176-191 were sendArithmeticSelectorBytecode" (176 bytecodePrimAdd) (177 bytecodePrimSubtract) (178 bytecodePrimLessThan) (179 bytecodePrimGreaterThan) (180 bytecodePrimLessOrEqual) (181 bytecodePrimGreaterOrEqual) (182 bytecodePrimEqual) (183 bytecodePrimNotEqual) (184 bytecodePrimMultiply) (185 bytecodePrimDivide) (186 bytecodePrimMod) (187 bytecodePrimMakePoint) (188 bytecodePrimBitShift) (189 bytecodePrimDiv) (190 bytecodePrimBitAnd) (191 bytecodePrimBitOr) "192-207 were sendCommonSelectorBytecode" (192 bytecodePrimAt) (193 bytecodePrimAtPut) (194 bytecodePrimSize) (195 bytecodePrimNext) (196 bytecodePrimNextPut) (197 bytecodePrimAtEnd) (198 bytecodePrimIdentical) (199 bytecodePrimClass) (200 bytecodePrimNotIdentical) "was bytecodePrimSpecialSelector24 / blockCopy" (201 bytecodePrimValue) (202 bytecodePrimValueWithArg) (203 bytecodePrimDo) (204 bytecodePrimNew) (205 bytecodePrimNewWithArg) (206 bytecodePrimPointX) (207 bytecodePrimPointY) (208 223 sendLiteralSelector0ArgsBytecode) (224 239 sendLiteralSelector1ArgBytecode) (240 255 sendLiteralSelector2ArgsBytecode) )! Item was changed: ----- Method: StackInterpreter class>>initializeMiscConstants (in category 'initialization') ----- initializeMiscConstants super initializeMiscConstants. STACKVM := true. "These flags function to identify a GC operation, or to specify what operations the leak checker should be run for." GCModeFull := 1. "stop-the-world global GC" GCModeNewSpace := 2. "Spur's scavenge, or V3's incremental" GCModeIncremental := 4. "incremental global gc (Dijkstra tri-colour marking); as yet unimplemented" GCModeBecome := 8. "v3 post-become sweeping/Spur forwarding" GCModeImageSegment := 16. "just a flag for leak checking image segments" GCModeFreeSpace := 32. "just a flag for leak checking free space; Spur only" GCCheckPrimCall := 64. "just a flag for leak checking external primitive calls" StackPageTraceInvalid := -1. StackPageUnreached := 0. StackPageReachedButUntraced := 1. StackPageTraced := 2. DumpStackOnLowSpace := 0. MillisecondClockMask := 16r1FFFFFFF. "Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)" MaxExternalPrimitiveTableSize := 4096. "entries" MaxJumpBuf := 32. "max. callback depth" + FailImbalancedPrimitives := InitializationOptions at: #FailImbalancedPrimitives ifAbsentPut: [true]. + EnforceAccessControl := InitializationOptions at: #EnforceAccessControl ifAbsent: [true]! - FailImbalancedPrimitives := initializationOptions at: #FailImbalancedPrimitives ifAbsentPut: [true]. - EnforceAccessControl := initializationOptions at: #EnforceAccessControl ifAbsent: [true]! Item was changed: ----- Method: StackInterpreter class>>initializeWithOptions: (in category 'initialization') ----- initializeWithOptions: optionsDictionary "StackInterpreter initializeWithOptions: Dictionary new" super initializeWithOptions: optionsDictionary. - (self primitivesClass withAllSuperclasses copyUpTo: StackInterpreter) do: - [:class| class initializationOptions: initializationOptions]. self initializeMiscConstants. "must precede other initialization." self initializeAssociationIndex. self initializeBytecodeTable. self initializeCaches. self initializeCharacterIndex. self initializeCharacterScannerIndices. self initializeClassIndices. self initializeContextIndices. self initializeDirectoryLookupResultCodes. self initializeFrameIndices. self initializeMessageIndices. self initializeMethodIndices. self initializePointIndices. self initializePrimitiveTable. self initializeSchedulerIndices. self initializeSmallIntegers. self initializeStreamIndices! Item was changed: ----- Method: StackInterpreter class>>writeVMHeaderTo:bytesPerWord:generator: (in category 'translation') ----- writeVMHeaderTo: aStream bytesPerWord: bytesPerWord generator: aCCodeGenerator super writeVMHeaderTo: aStream bytesPerWord: bytesPerWord generator: aCCodeGenerator. SistaVM ifTrue: [aCCodeGenerator putDefineOf: #SistaVM as: 1 on: aStream]. NewspeakVM ifTrue: [aCCodeGenerator putDefineOf: #NewspeakVM as: 1 on: aStream]. MULTIPLEBYTECODESETS ifTrue: [aCCodeGenerator putDefineOf: #MULTIPLEBYTECODESETS as: 1 on: aStream]. IMMUTABILITY ifTrue: [aCCodeGenerator putConditionalDefineOf: #IMMUTABILITY as: 1 comment: 'Allow this to be overridden on the compiler command line' on: aStream]. SistaVM | NewspeakVM | MULTIPLEBYTECODESETS | IMMUTABILITY ifTrue: [aStream cr]. aCCodeGenerator putDefineOf: #STACKVM as: 1 on: aStream. + (InitializationOptions at: #SpurObjectMemory ifAbsent: false) ifTrue: - (initializationOptions at: #SpurObjectMemory ifAbsent: false) ifTrue: [aCCodeGenerator putDefineOf: #SPURVM as: 1 on: aStream]! Item was changed: ----- Method: StackInterpreterSimulator class>>initializeWithOptions:objectMemoryClass: (in category 'class initialization') ----- initializeWithOptions: optionsDictionaryOrArray objectMemoryClass: objectMemoryClassOrNil "The relevant ObjectMemory and Interpreter classes must be initialized in order. This happens notionally every time we start the simulator, but in fact happens when ever we instantiate a simulator." + InitializationOptions := optionsDictionaryOrArray isArray - initializationOptions := optionsDictionaryOrArray isArray ifTrue: [Dictionary newFromPairs: optionsDictionaryOrArray] ifFalse: [optionsDictionaryOrArray]. - (self allSuperclasses copyUpThrough: InterpreterPrimitives) do: - [:sc| sc initializationOptions: initializationOptions]. - (objectMemoryClassOrNil ifNil: [self objectMemoryClass]) + initializeWithOptions: InitializationOptions. - initializeWithOptions: initializationOptions. + self initializeWithOptions: InitializationOptions! - self initializeWithOptions: initializationOptions! Item was added: + ----- Method: StackToRegisterMappingCogit class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + ^super ancilliaryClasses, + { self basicNew simStackEntryClass. self basicNew bytecodeFixupClass. CogSSOptStatus } , + (LowcodeVM ifTrue: [ { self basicNew simStackNativeEntryClass } ] ifFalse: [ #() ])! Item was removed: - ----- Method: StackToRegisterMappingCogit class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - ^(super ancilliaryClasses: options), - { self basicNew simStackEntryClass. self basicNew bytecodeFixupClass. CogSSOptStatus } , - (LowcodeVM ifTrue: [ { self basicNew simStackNativeEntryClass } ] ifFalse: [ #() ])! Item was changed: ----- Method: StackToRegisterMappingCogit class>>initializeBytecodeTableForSqueakV3PlusClosures (in category 'class initialization') ----- initializeBytecodeTableForSqueakV3PlusClosures "StackToRegisterMappingCogit initializeBytecodeTableForSqueakV3PlusClosures" numPushNilsFunction := #v3:Num:Push:Nils:. pushNilSizeFunction := #v3PushNilSize:numInitialNils:. FirstSpecialSelector := 176. NumSpecialSelectors := 32. self flag: 'Special selector send class must be inlined to agree with the interpreter, which inlines class. If class is sent to e.g. a general instance of ProtoObject then unless class is inlined there will be an MNU. It must be that the Cointerpreter and Cogit have identical semantics. We get away with not hardwiring the other special selectors either because in the Cointerpreter they are not inlined or because they are inlined only to instances of classes for which there will always be a method.'. self generatorTableFrom: #( (1 0 15 genPushReceiverVariableBytecode isInstVarRef needsFrameNever: 1) (1 16 31 genPushTemporaryVariableBytecode needsFrameIfMod16GENumArgs: 1) (1 32 63 genPushLiteralConstantBytecode needsFrameNever: 1) (1 64 95 genPushLiteralVariableBytecode needsFrameNever: 1) (1 96 103 genStoreAndPopReceiverVariableBytecode isInstVarRef is1ByteInstVarStore isMappedIfImmutability needsFrameIfImmutability: -1) (1 104 111 genStoreAndPopTemporaryVariableBytecode) (1 112 112 genPushReceiverBytecode needsFrameNever: 1) (1 113 113 genPushConstantTrueBytecode needsFrameNever: 1) (1 114 114 genPushConstantFalseBytecode needsFrameNever: 1) (1 115 115 genPushConstantNilBytecode needsFrameNever: 1) (1 116 119 genPushQuickIntegerConstantBytecode needsFrameNever: 1) "method returns in blocks need a frame because of nonlocalReturn:through:" (1 120 120 genReturnReceiver return needsFrameIfInBlock: isMappedInBlock 0) (1 121 121 genReturnTrue return needsFrameIfInBlock: isMappedInBlock 0) (1 122 122 genReturnFalse return needsFrameIfInBlock: isMappedInBlock 0) (1 123 123 genReturnNil return needsFrameIfInBlock: isMappedInBlock 0) (1 124 124 genReturnTopFromMethod return needsFrameIfInBlock: isMappedInBlock -1) (1 125 125 genReturnTopFromBlock return needsFrameNever: -1) (1 126 127 unknownBytecode) (2 128 128 extendedPushBytecode isInstVarRef) "well, maybe inst var ref" (2 129 129 extendedStoreBytecode isInstVarRef isMappedIfImmutability) "well, maybe inst var ref" (2 130 130 extendedStoreAndPopBytecode isInstVarRef isMappedIfImmutability) "well, maybe inst var ref" (2 131 131 genExtendedSendBytecode isMapped) (3 132 132 doubleExtendedDoAnythingBytecode isMapped) "well, maybe inst var ref" (2 133 133 genExtendedSuperBytecode isInstVarRef isMapped) (2 134 134 genSecondExtendedSendBytecode isMapped) (1 135 135 genPopStackBytecode needsFrameNever: -1) (1 136 136 duplicateTopBytecode needsFrameNever: 1) (1 137 137 genPushActiveContextBytecode) (2 138 138 genPushNewArrayBytecode)), + ((InitializationOptions at: #SpurObjectMemory ifAbsent: [false]) - ((initializationOptions at: #SpurObjectMemory ifAbsent: [false]) ifTrue: [#((3 139 139 genCallPrimitiveBytecode))] ifFalse: [#((1 139 139 unknownBytecode))]), #( (3 140 140 genPushRemoteTempLongBytecode) (3 141 141 genStoreRemoteTempLongBytecode) (3 142 142 genStoreAndPopRemoteTempLongBytecode) (4 143 143 genPushClosureCopyCopiedValuesBytecode block v3:Block:Code:Size:) (1 144 151 genShortUnconditionalJump branch v3:ShortForward:Branch:Distance:) (1 152 159 genShortJumpIfFalse branch isBranchFalse isMapped "because of mustBeBoolean" v3:ShortForward:Branch:Distance:) (2 160 163 genLongUnconditionalBackwardJump branch isMapped "because of interrupt check" v3:Long:Branch:Distance:) (2 164 167 genLongUnconditionalForwardJump branch v3:Long:Branch:Distance:) (2 168 171 genLongJumpIfTrue branch isBranchTrue isMapped "because of mustBeBoolean" v3:LongForward:Branch:Distance:) (2 172 175 genLongJumpIfFalse branch isBranchFalse isMapped "because of mustBeBoolean" v3:LongForward:Branch:Distance:) (1 176 176 genSpecialSelectorArithmetic isMapped AddRR) (1 177 177 genSpecialSelectorArithmetic isMapped SubRR) (1 178 178 genSpecialSelectorComparison isMapped JumpLess) (1 179 179 genSpecialSelectorComparison isMapped JumpGreater) (1 180 180 genSpecialSelectorComparison isMapped JumpLessOrEqual) (1 181 181 genSpecialSelectorComparison isMapped JumpGreaterOrEqual) (1 182 182 genSpecialSelectorComparison isMapped JumpZero) (1 183 183 genSpecialSelectorComparison isMapped JumpNonZero) (1 184 189 genSpecialSelectorSend isMapped) " #* #/ #\\ #@ #bitShift: //" (1 190 190 genSpecialSelectorArithmetic isMapped AndRR) (1 191 191 genSpecialSelectorArithmetic isMapped OrRR) (1 192 197 genSpecialSelectorSend isMapped) "#at: #at:put: #size #next #nextPut: #atEnd" (1 198 198 genSpecialSelectorEqualsEquals needsFrameNever: notMapped -1) "not mapped because it is directly inlined (for now)" (1 199 199 genSpecialSelectorClass needsFrameIfStackGreaterThanOne: notMapped 0) "not mapped because it is directly inlined (for now)" (1 200 200 genSpecialSelectorNotEqualsEquals needsFrameNever: notMapped -1) "not mapped because it is directly inlined (for now)" (1 201 207 genSpecialSelectorSend isMapped) " #value #value: #do: #new #new: #x #y" (1 208 223 genSendLiteralSelector0ArgsBytecode isMapped) (1 224 239 genSendLiteralSelector1ArgBytecode isMapped) (1 240 255 genSendLiteralSelector2ArgsBytecode isMapped))! Item was added: + ----- Method: ThreadedFFIPlugin class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + ^{ self calloutStateClass }! Item was removed: - ----- Method: ThreadedFFIPlugin class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - ^{ self calloutStateClass }! Item was added: + ----- Method: ThreadedX64SysVFFIPlugin class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + ^{ self calloutStateClass. ThreadedFFIX64SixteenByteReturn }! Item was removed: - ----- Method: ThreadedX64SysVFFIPlugin class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: options - ^{ self calloutStateClass. ThreadedFFIX64SixteenByteReturn }! Item was changed: Object subclass: #VMClass instanceVariableNames: '' + classVariableNames: 'DefaultBase ExpensiveAsserts InitializationOptions' - classVariableNames: 'DefaultBase ExpensiveAsserts' poolDictionaries: 'VMBasicConstants VMObjectIndices' category: 'VMMaker-Support'! VMClass class + instanceVariableNames: 'timeStamp'! - instanceVariableNames: 'timeStamp initializationOptions'! + !VMClass commentStamp: 'eem 6/7/2018 15:16' prior: 0! + I am an abstract superclass for all classes in the VM that want to maintain a source timeStamp. I am also the holder of the InitializationOptions class variable which holds options such as which JIT or which memory manager to use when creating or generating a VM.! - !VMClass commentStamp: '<historical>' prior: 0! - I am an abstract superclass for all classes in the VM that want to maintain a source timeStamp.! VMClass class + instanceVariableNames: 'timeStamp'! - instanceVariableNames: 'timeStamp initializationOptions'! Item was added: + ----- Method: VMClass class>>ancilliaryClasses (in category 'translation') ----- + ancilliaryClasses + "Answer any extra classes to be included in the translation." + ^{}! Item was removed: - ----- Method: VMClass class>>ancilliaryClasses: (in category 'translation') ----- - ancilliaryClasses: optionsDictionary - "Answer any extra classes to be included in the translation." - ^{}! Item was changed: ----- Method: VMClass class>>cogitClass (in category 'accessing class hierarchy') ----- cogitClass "Answer the cogitClass in effect. Ensure that StackInterpreter has a nil cogitClass." (self isInterpreterClass and: [self hasCogit not]) ifTrue: [^nil]. + ^Smalltalk classNamed: (InitializationOptions + at: #Cogit + ifAbsent: [#StackToRegisterMappingCogit])! - ^initializationOptions ifNotNil: - [Smalltalk classNamed: (initializationOptions - at: #Cogit - ifAbsent: [#StackToRegisterMappingCogit])]! Item was changed: ----- Method: VMClass class>>initializationOptions (in category 'initialization') ----- initializationOptions + ^InitializationOptions! - ^initializationOptions! Item was removed: - ----- Method: VMClass class>>initializationOptions: (in category 'initialization') ----- - initializationOptions: optionsDictionary - initializationOptions := optionsDictionary! Item was changed: ----- Method: VMClass class>>initialize (in category 'initialization') ----- initialize + InitializationOptions ifNil: [InitializationOptions := Dictionary new]. (Utilities classPool at: #CommonRequestStrings ifAbsent: []) ifNotNil: [:commonRequestStringHolder| (commonRequestStringHolder contents asString includesSubstring: 'VMClass open') ifFalse: [Utilities appendToCommonRequests: '-\VMMaker generateConfiguration\VMMaker generateAllConfigurationsUnderVersionControl\VMMaker generateAllSpurConfigurations\VMClass openCogMultiWindowBrowser\VMClass openObjectMemoriesInterpretersBrowser\VMClass openSpurMultiWindowBrowser\VMClass openCogSpurMultiWindowBrowser\VMClass openCogitMultiWindowBrowser' withCRs]]. ExpensiveAsserts := false! Item was changed: ----- Method: VMClass class>>initializeMiscConstants (in category 'initialization') ----- initializeMiscConstants "Falsify the `what type of VM is this?' flags that are defined in the various interp.h files. Subclass implementations need to include a super initializeMiscConstants" | omc | VMBIGENDIAN class. "Mention this for the benefit of CCodeGenerator>>emitCConstantsOn:" SPURVM := STACKVM := COGVM := COGMTVM := false. + InitializationOptions ifNil: [InitializationOptions := Dictionary new]. + omc := InitializationOptions at: #ObjectMemory ifAbsent: nil. - initializationOptions ifNil: [self initializationOptions: Dictionary new]. - omc := initializationOptions at: #ObjectMemory ifAbsent: nil. (omc isNil and: [self defaultObjectMemoryClass notNil]) ifTrue: + [omc := InitializationOptions at: #ObjectMemory put: self defaultObjectMemoryClass name]. + InitializationOptions - [omc := initializationOptions at: #ObjectMemory put: self defaultObjectMemoryClass name]. - initializationOptions at: #SqueakV3ObjectMemory "the good ole default" ifAbsentPut: (omc ifNil: [true] ifNotNil: [(Smalltalk at: omc) includesBehavior: ObjectMemory]); at: #SpurObjectMemory "the new contender" ifAbsentPut: (omc ifNil: [false] ifNotNil: [(Smalltalk at: omc) includesBehavior: SpurMemoryManager]). "Use ifAbsentPut: so that they will get copied back to the VMMaker's options and dead code will likely be eliminated." + PharoVM := InitializationOptions at: #PharoVM ifAbsentPut: [false]. + NewspeakVM := InitializationOptions at: #NewspeakVM ifAbsentPut: [false]. + SistaVM := InitializationOptions at: #SistaVM ifAbsentPut: [false]. + TempVectReadBarrier := InitializationOptions at: #TempVectReadBarrier ifAbsentPut: [false]. + LowcodeVM := InitializationOptions at: #LowcodeVM ifAbsentPut: [false]. + MULTIPLEBYTECODESETS := InitializationOptions at: #MULTIPLEBYTECODESETS ifAbsentPut: [false]. - PharoVM := initializationOptions at: #PharoVM ifAbsentPut: [false]. - NewspeakVM := initializationOptions at: #NewspeakVM ifAbsentPut: [false]. - SistaVM := initializationOptions at: #SistaVM ifAbsentPut: [false]. - TempVectReadBarrier := initializationOptions at: #TempVectReadBarrier ifAbsentPut: [false]. - LowcodeVM := initializationOptions at: #LowcodeVM ifAbsentPut: [false]. - MULTIPLEBYTECODESETS := initializationOptions at: #MULTIPLEBYTECODESETS ifAbsentPut: [false]. "Simulation only; on by default..." + CloneOnGC := InitializationOptions at: #CloneOnGC ifAbsentPut: [true]. + CloneOnScavenge := InitializationOptions at: #CloneOnScavenge ifAbsentPut: [true]. - CloneOnGC := initializationOptions at: #CloneOnGC ifAbsentPut: [true]. - CloneOnScavenge := initializationOptions at: #CloneOnScavenge ifAbsentPut: [true]. "These must be set only if specified, not defaulted, because they are set on the command line or in include files." + InitializationOptions - initializationOptions at: #VMBIGENDIAN ifPresent: [:value| VMBIGENDIAN := value]; at: #ObjectMemory ifPresent: [:value| SPURVM := value beginsWith: 'Spur']; at: #STACKVM ifPresent: [:value| STACKVM := value]; + at: #COGVM ifPresent: [:value| COGVM := InitializationOptions at: #COGVM]; + at: #COGMTVM ifPresent: [:value| COGMTVM := InitializationOptions at: #COGMTVM]. - at: #COGVM ifPresent: [:value| COGVM := initializationOptions at: #COGVM]; - at: #COGMTVM ifPresent: [:value| COGMTVM := initializationOptions at: #COGMTVM]. "consistency checks" + SPURVM + ifTrue: + [(TempVectReadBarrier not + and: [{SpurMemoryManager compactorClass}, (SpurMemoryManager compactorClass ancilliaryClasses) anySatisfy: + [:c| c == SpurSelectiveCompactor]]) ifTrue: + [self error: 'Selective compactor requires read barrier']] + ifFalse: + [TempVectReadBarrier ifTrue: [self error: 'read barrier works with spur VM only...']. + SistaVM ifTrue: [self error: 'Sista VM works with spur VM only...']]. - (TempVectReadBarrier and: [SPURVM not]) ifTrue: [self error: 'read barrier works with spur VM only...']. - (SistaVM and: [SPURVM not]) ifTrue: [self error: 'Sista VM works with spur VM only...']. - ((initializationOptions at: #compactorClass ifAbsent: []) = #SpurSelectiveCompactor and: [TempVectReadBarrier not]) ifTrue: [self error: 'Selective compactor requires read barrier']. "And not these; they're compile-time" + IMMUTABILITY := InitializationOptions at: #IMMUTABILITY ifAbsent: [SPURVM] "Default as enabled for Spur VMs"! - IMMUTABILITY := initializationOptions at: #IMMUTABILITY ifAbsent: [SPURVM] "Default as enabled for Spur VMs"! Item was changed: ----- Method: VMClass class>>initializeWithOptions: (in category 'initialization') ----- initializeWithOptions: optionsDictionaryOrArray "Initialize the receiver, typically initializing class variables. Initialize any class variables whose names occur in optionsDictionary with the corresponding values there-in." + InitializationOptions := optionsDictionaryOrArray isArray + ifTrue: [Dictionary newFromPairs: optionsDictionaryOrArray] + ifFalse: [optionsDictionaryOrArray]. - | optionsDictionary | - optionsDictionary := optionsDictionaryOrArray isArray - ifTrue: [Dictionary newFromPairs: optionsDictionaryOrArray] - ifFalse: [optionsDictionaryOrArray]. - "This is necessary. e.g. if the receiver is CoInterpreterPrimitives, - it is still necessary to set the options in CoInterpreter. Otherwise, - some class in the chain may have stale options, and when building - the code generator, a stale ancilliary class may be computed." - (self withAllSuperclasses copyUpThrough: VMClass) do: - [:class| - class initializationOptions: optionsDictionary]. + ExpensiveAsserts := InitializationOptions at: #ExpensiveAsserts ifAbsent: [false]! - ExpensiveAsserts := optionsDictionary at: #ExpensiveAsserts ifAbsent: [false]! Item was changed: ----- Method: VMClass class>>objectMemoryClass (in category 'accessing class hierarchy') ----- objectMemoryClass + InitializationOptions ifNil: - initializationOptions ifNil: [^self defaultObjectMemoryClass]. + ^Smalltalk at: (InitializationOptions - ^Smalltalk at: (initializationOptions at: #ObjectMemory ifAbsent: [^self defaultObjectMemoryClass])! Item was changed: ----- Method: VMClass class>>shouldIncludeMethodForSelector: (in category 'translation') ----- shouldIncludeMethodForSelector: selector "Answer whether a primitive method should be translated. Emit a warning to the transcript if the method doesn't exist." ^(self whichClassIncludesSelector: selector) ifNotNil: [:c| (c >> selector pragmaAt: #option:) ifNotNil: [:pragma| (VMBasicConstants defineAtCompileTime: pragma arguments first) + or: [InitializationOptions - or: [initializationOptions at: pragma arguments first ifAbsent: [(self bindingOf: pragma arguments first) ifNil: [false] ifNotNil: [:binding| binding value ~~ #undefined]]]] ifNil: [true]] ifNil: [Transcript nextPutAll: 'Cannot find implementation of '; nextPutAll: selector; nextPutAll: ' in hierarchy of '; print: self; cr; flush. false]! Item was changed: ----- Method: VMMaker>>buildCodeGeneratorForCogit:includeAPIMethods:initializeClasses: (in category 'generate sources') ----- buildCodeGeneratorForCogit: cogitClass includeAPIMethods: getAPIMethods initializeClasses: initializeClasses "Answer the code generator for translating the cogit." | cg cogitClasses | cg := self createCogitCodeGenerator. cg vmClass: cogitClass. initializeClasses ifTrue: [{ cogitClass. self interpreterClass. self interpreterClass objectMemoryClass } do: [:cgc| (cgc respondsTo: #initializeWithOptions:) ifTrue: [cgc initializeWithOptions: optionsDictionary] ifFalse: [cgc initialize]]]. cogitClasses := OrderedCollection withAll: (cogitClass withAllSuperclasses copyUpThrough: VMClass) reverse. + cogitClasses addAllLast: (cogitClass ancilliaryClasses reject: [:class| class isStructClass]). - cogitClasses addAllLast: ((cogitClass ancilliaryClasses: optionsDictionary) reject: [:class| class isStructClass]). cogitClasses do: [:cgc| cg addClass: cgc]. "Now make sure to add struct classes that the most specific subclasses specify. This makes sure that struct classes are ordered as the most specific cogitClass desires. This must happen for references between the struct classes to be resolved in a specific order." cogitClasses := OrderedCollection with: cogitClass with: cogitClass objectRepresentationClass. + cogitClasses addAll: (cogitClass ancilliaryClasses reject: - cogitClasses addAll: ((cogitClass ancilliaryClasses: optionsDictionary) reject: [:class| class isStructClass or: [cogitClass objectRepresentationClass includesBehavior: class]]). cg addStructClasses: (cg structClassesForTranslationClasses: cogitClasses). getAPIMethods ifTrue: [cg includeAPIFrom: (self buildCodeGeneratorForInterpreter: self interpreterClass includeAPIMethods: false initializeClasses: false)]. ^cg! 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 | initializeClasses ifTrue: [interpreterClass initializeWithOptions: optionsDictionary. interpreterClass hasCogit ifTrue: + [interpreterClass cogitClass initializeWithOptions: optionsDictionary]]. - [interpreterClass cogitClass initializeWithOptions: optionsDictionary]. - interpreterClass objectMemoryClass initializationOptions: 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. [theClass ~~ VMClass] whileTrue: + [interpreterClasses addFirst: theClass. - [theClass initializationOptions: interpreterClass initializationOptions. - interpreterClasses addFirst: theClass. theClass := theClass superclass]]. interpreterClasses addFirst: VMClass; addAllLast: (cg nonStructClassesForTranslationClasses: interpreterClasses). 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). interpreterClasses do: [:ic| cg addClass: ic]. getAPIMethods ifTrue: [interpreterClass cogitClass ifNotNil: [:cogitClass| cg includeAPIFrom: (self buildCodeGeneratorForCogit: cogitClass includeAPIMethods: false initializeClasses: false)]]. ^cg! Item was changed: ----- Method: VMMaker>>needsToRegenerateCogitFile (in category 'generate sources') ----- needsToRegenerateCogitFile "Check the timestamp for the relevant classes and then the timestamp for the main source file (e.g. interp.c) file if it already exists. Answer if the file needs regenerating." | cogitClass cogitClasses tStamp files | cogitClasses := (cogitClass := self interpreterClass cogitClass) withAllSuperclasses copyUpThrough: Cogit. + cogitClasses addAllLast: cogitClass ancilliaryClasses. - cogitClasses addAllLast: (cogitClass ancilliaryClasses: self options). tStamp := cogitClasses inject: 0 into: [:tS :cl| tS max: cl timeStamp]. "don't translate if the file(s) is newer than my timeStamp" files := (self coreVMDirectory fileNamesMatching: cogitClass activeCompilerClass moduleName, '*.c'). files isEmpty ifTrue: [^true]. (files allSatisfy: [:fileName| (self coreVMDirectory entryAt: fileName ifAbsent: [nil]) ifNil: [false] ifNotNil: [:fstat| | mTime | mTime := fstat modificationTime. mTime isInteger ifFalse: [mTime := mTime asSeconds]. tStamp < mTime]]) ifTrue: [^self confirm: ('The ', self configurationNameIfAny, cogitClass printString, ', ', cogitClass activeCompilerClass, '\classes have not been modified since the ', cogitClass processorSpecificSourceFileName, ' source file\was last generated. Do you still want to regenerate it?') withCRs]. ^true! Item was changed: ----- Method: VMMaker>>needsToRegenerateInterpreterFile (in category 'initialize') ----- needsToRegenerateInterpreterFile "Check the timestamp for the relevant classes and then the timestamp for the main source file (e.g. interp.c) if it already exists. Answer if the file needs regenerating." | classes tStamp | classes := self interpreterClass withAllSuperclasses copyUpTo: VMClass. self interpreterClass objectMemoryClass ifNotNil: [:objectMemoryClass| classes addAllLast: (objectMemoryClass withAllSuperclasses copyUpTo: VMClass)]. classes copy do: + [:class| classes addAllLast: class ancilliaryClasses]. - [:class| classes addAllLast: (class ancilliaryClasses: self options)]. tStamp := classes inject: 0 into: [:tS :cl| tS max: cl timeStamp]. "don't translate if the file is newer than my timeStamp" (self coreVMDirectory entryAt: self interpreterFilename ifAbsent: [nil]) ifNotNil: [:fstat| | mTime | mTime := fstat modificationTime. mTime isInteger ifFalse: [mTime := mTime asSeconds]. tStamp < mTime ifTrue: [^self confirm: 'The ', self configurationNameIfAny, 'interpreter classes have not been modified since\ the interpreter file was last generated.\Do you still want to regenerate the source file?' withCRs]]. ^true !

1 0

VM Maker: VMMaker.oscog-cb.2407.mcz
by commits＠source.squeak.org 07 Jun '18

07 Jun '18

ClementBera uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-cb.2407.mcz ==================== Summary ==================== Name: VMMaker.oscog-cb.2407 Author: cb Time: 7 June 2018, 9:17:01.910973 pm UUID: f5b4c84b-f7cf-4c4e-bee3-5ee2feee88d7 Ancestors: VMMaker.oscog-cb.2406 Fixing cases where double linked list prev pointer was not correctly updated. Still have a bug where the first free chunk of a linked list has a prev pointer instead of 0. =============== Diff against VMMaker.oscog-cb.2406 =============== Item was changed: ----- Method: SpurMemoryManager>>addToFreeList:bytes: (in category 'free space') ----- addToFreeList: freeChunk bytes: chunkBytes "Add freeChunk to the relevant freeList. For the benefit of sortedFreeObject:, if freeChunk is large, answer the treeNode it is added to, if it is added to the next list of a freeTreeNode, otherwise answer 0." | index | "coInterpreter transcript ensureCr. coInterpreter print: 'freeing '. self printFreeChunk: freeChunk." self assert: (self isFreeObject: freeChunk). self assert: chunkBytes = (self bytesInObject: freeChunk). index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: [self setNextFreeChunkOf: freeChunk withValue: (freeLists at: index) chunkBytes: chunkBytes. + (self bytesBigEnoughForPrevPointer: chunkBytes) ifTrue: + [self storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0]. - self storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0. freeLists at: index put: freeChunk. freeListsMask := freeListsMask bitOr: 1 << index. ^0]. ^self addToFreeTree: freeChunk bytes: chunkBytes! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfBytes: (in category 'free space') ----- allocateOldSpaceChunkOfBytes: chunkBytes "Answer a chunk of oldSpace from the free lists, if available, otherwise answer nil. Break up a larger chunk if one of the exact size does not exist. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | initialIndex chunk index nodeBytes parent child | "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)" initialIndex := chunkBytes / self allocationUnit. (initialIndex < self numFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue: [(freeListsMask anyMask: 1 << initialIndex) ifTrue: [(chunk := freeLists at: initialIndex) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assert: (self isValidFreeObject: chunk). + ^self unlinkFreeChunk: chunk atIndex: initialIndex chunkBytes: chunkBytes]. - ^self unlinkFreeChunk: chunk atIndex: initialIndex]. freeListsMask := freeListsMask - (1 << initialIndex)]. "first search for free chunks of a multiple of chunkBytes in size" index := initialIndex. [(index := index + index) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(chunk := freeLists at: index) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assert: (self isValidFreeObject: chunk). + self unlinkFreeChunk: chunk atIndex: index chunkBytes: chunkBytes. - self unlinkFreeChunk: chunk atIndex: index. self assert: (self bytesInObject: chunk) = (index * self allocationUnit). self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: chunk) + chunkBytes. ^chunk]. freeListsMask := freeListsMask - (1 << index)]]. "now get desperate and use the first that'll fit. Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence start at initialIndex + 2." index := initialIndex + 1. [(index := index + 1) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(chunk := freeLists at: index) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assert: (self isValidFreeObject: chunk). + self unlinkFreeChunk: chunk atIndex: index chunkBytes: chunkBytes. - self unlinkFreeChunk: chunk atIndex: index. self assert: (self bytesInObject: chunk) = (index * self allocationUnit). self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: chunk) + chunkBytes. ^chunk]. freeListsMask := freeListsMask - (1 << index)]]]. "Large chunk, or no space on small free lists. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the smallest chunk at least as large as chunkBytes, or 0 if none." parent := 0. child := freeLists at: 0. [child ~= 0] whileTrue: [| childBytes | self assert: (self isValidFreeObject: child). childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. chunk ~= 0 ifTrue: [self assert: (self isValidFreeObject: chunk). self setNextFreeChunkOf: child withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk) bytesBigEnoughForPrevPointer: true. ^self startOfObject: chunk]. nodeBytes := childBytes. parent := child. child := 0] "break out of loop to remove interior node" ifFalse: ["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger." childBytes <= (chunkBytes + self allocationUnit) ifTrue: "node too small; walk down the larger size of the tree" [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child] ifFalse: [parent := child. "parent will be smallest node >= chunkBytes + allocationUnit" nodeBytes := childBytes. child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]]. parent = 0 ifTrue: [totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded" ^nil]. "self printFreeChunk: parent" self assert: (nodeBytes = chunkBytes or: [nodeBytes >= (chunkBytes + (2 * self allocationUnit))]). self assert: (self bytesInObject: parent) = nodeBytes. "attempt to remove from list" chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: parent. chunk ~= 0 ifTrue: [self assert: (chunkBytes = nodeBytes or: [chunkBytes + self allocationUnit < nodeBytes]). self setNextFreeChunkOf: parent withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk) bytesBigEnoughForPrevPointer: true. chunkBytes ~= nodeBytes ifTrue: [self freeChunkWithBytes: nodeBytes - chunkBytes at: (self startOfObject: chunk) + chunkBytes]. ^self startOfObject: chunk]. "no list; remove the interior node" chunk := parent. self unlinkSolitaryFreeTreeNode: chunk. "if there's space left over, add the fragment back." chunkBytes ~= nodeBytes ifTrue: [self freeChunkWithBytes: nodeBytes - chunkBytes at: (self startOfObject: chunk) + chunkBytes]. ^self startOfObject: chunk! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfBytes:suchThat: (in category 'free space') ----- allocateOldSpaceChunkOfBytes: chunkBytes suchThat: acceptanceBlock "Answer a chunk of oldSpace from the free lists that satisfies acceptanceBlock, if available, otherwise answer nil. Break up a larger chunk if one of the exact size cannot be found. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | initialIndex node next prev index child childBytes acceptedChunk acceptedNode | <inline: true> "must inline for acceptanceBlock" "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)" initialIndex := chunkBytes / self allocationUnit. (initialIndex < self numFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue: [(freeListsMask anyMask: 1 << initialIndex) ifTrue: [(node := freeLists at: initialIndex) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << initialIndex)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 + ifTrue: [self unlinkFreeChunk: node atIndex: index chunkBytes: chunkBytes] - ifTrue: [freeLists at: initialIndex put: next] ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. ^node]. prev := node. node := next]]]. "first search for free chunks of a multiple of chunkBytes in size" index := initialIndex. [(index := index + initialIndex) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << index)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 + ifTrue: [self unlinkFreeChunk: node atIndex: index chunkBytes: chunkBytes] - ifTrue: [freeLists at: index put: next] ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: node) + chunkBytes. ^node]. prev := node. node := next]]]]. "now get desperate and use the first that'll fit. Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence start at initialIndex + 2." index := initialIndex + 1. [(index := index + 1) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << index)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 + ifTrue: [self unlinkFreeChunk: node atIndex: index chunkBytes: chunkBytes] - ifTrue: [freeLists at: index put: next] ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: node) + chunkBytes. ^node]. prev := node. node := next]]]]]. "Large chunk, or no space on small free lists. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the smallest chunk at least as large as chunkBytes, or 0 if none. acceptedChunk and acceptedNode save us from having to back-up when the acceptanceBlock filters-out all nodes of the right size, but there are nodes of the wrong size it does accept." child := freeLists at: 0. node := acceptedChunk := acceptedNode := 0. [child ~= 0] whileTrue: [self assert: (self isValidFreeObject: child). childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [node := child. [prev := node. node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. node ~= 0] whileTrue: [(acceptanceBlock value: node) ifTrue: [self assert: (self isValidFreeObject: node). self setNextFreeChunkOf: prev withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) bytesBigEnoughForPrevPointer: true. ^self startOfObject: node]]. (acceptanceBlock value: child) ifTrue: [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: child] ifFalse: "list; replace node with it" [self inFreeTreeReplace: child with: next]. ^self startOfObject: child]]. child ~= 0 ifTrue: ["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger." childBytes <= (chunkBytes + self allocationUnit) ifTrue: "node too small; walk down the larger size of the tree" [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child] ifFalse: [self flag: 'we can do better here; preferentially choosing the lowest node. That would be a form of best-fit since we are trying to compact down'. node := child. child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node. acceptedNode = 0 ifTrue: [acceptedChunk := node. "first search the list." [acceptedChunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk. (acceptedChunk ~= 0 and: [acceptanceBlock value: acceptedChunk]) ifTrue: [acceptedNode := node]. acceptedChunk ~= 0 and: [acceptedNode = 0]] whileTrue. "nothing on the list; will the node do? This prefers acceptable nodes higher up the tree over acceptable list elements further down, but we haven't got all day..." (acceptedNode = 0 and: [acceptanceBlock value: node]) ifTrue: [acceptedNode := node. child := 0 "break out of loop now we have an acceptedNode"]]]]]. acceptedNode ~= 0 ifTrue: [acceptedChunk ~= 0 ifTrue: [self assert: (self bytesInObject: acceptedChunk) >= (chunkBytes + self allocationUnit). [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode. next ~= acceptedChunk] whileTrue: [acceptedNode := next]. self setNextFreeChunkOf: acceptedNode withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk) bytesBigEnoughForPrevPointer: true. self freeChunkWithBytes: (self bytesInObject: acceptedChunk) - chunkBytes at: (self startOfObject: acceptedChunk) + chunkBytes. ^self startOfObject: acceptedChunk]. next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: acceptedNode] ifFalse: "list; replace node with it" [self inFreeTreeReplace: acceptedNode with: next]. self assert: (self bytesInObject: acceptedNode) >= (chunkBytes + self allocationUnit). self freeChunkWithBytes: (self bytesInObject: acceptedNode) - chunkBytes at: (self startOfObject: acceptedNode) + chunkBytes. ^self startOfObject: acceptedNode]. totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded" ^nil! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes: (in category 'free space') ----- allocateOldSpaceChunkOfExactlyBytes: chunkBytes "Answer a chunk of oldSpace from the free lists, if one of this size is available, otherwise answer nil. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | index node child | "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) ~= 0 ifTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). totalFreeOldSpace := totalFreeOldSpace - chunkBytes. + ^self unlinkFreeChunk: node atIndex: index chunkBytes: chunkBytes]. - ^self unlinkFreeChunk: node atIndex: index]. freeListsMask := freeListsMask - (1 << index)]. ^nil]. "Large chunk. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the first chunk of the same size as chunkBytes, or 0 if none." child := freeLists at: 0. [child ~= 0] whileTrue: [| childBytes | self assert: (self isValidFreeObject: child). childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. node ~= 0 ifTrue: [self assert: (self isValidFreeObject: node). self setNextFreeChunkOf: child withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) bytesBigEnoughForPrevPointer: true. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: node]. "nothing acceptable on node's list; answer the node." self unlinkSolitaryFreeTreeNode: child. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: child] ifFalse: [child := self fetchPointer: (childBytes < chunkBytes ifTrue: [self freeChunkLargerIndex] ifFalse: [self freeChunkSmallerIndex]) ofFreeChunk: child]]. ^nil! Item was removed: - ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes:suchThat: (in category 'free space') ----- - allocateOldSpaceChunkOfExactlyBytes: chunkBytes suchThat: acceptanceBlock - "Answer a chunk of oldSpace from the free lists that satisfies acceptanceBlock, - if one of this size is available, otherwise answer nil. N.B. the chunk is simply a - pointer, it has no valid header. The caller *must* fill in the header correctly." - <var: #chunkBytes type: #usqInt> - | index node next prev child childBytes | - <inline: true> "must inline for acceptanceBlock" - "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" - - index := chunkBytes / self allocationUnit. - index < self numFreeLists ifTrue: - [(freeListsMask anyMask: 1 << index) ifTrue: - [(node := freeLists at: index) = 0 - ifTrue: [freeListsMask := freeListsMask - (1 << index)] - ifFalse: - [prev := 0. - [node ~= 0] whileTrue: - [self assert: node = (self startOfObject: node). - self assert: (self isValidFreeObject: node). - next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. - (acceptanceBlock value: node) ifTrue: - [prev = 0 - ifTrue: [freeLists at: index put: next] - ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. - totalFreeOldSpace := totalFreeOldSpace - chunkBytes. - ^node]. - prev := node. - node := next]]]. - ^nil]. - - "Large chunk. Search the large chunk list. - Large chunk list organized as a tree, each node of which is a list of - chunks of the same size. Beneath the node are smaller and larger - blocks. When the search ends parent should hold the first chunk of - the same size as chunkBytes, or 0 if none." - node := 0. - child := freeLists at: 0. - [child ~= 0] whileTrue: - [self "Sorry stepping over isValidFreeObject all the time was killing me" - cCode: [self assert: (self isValidFreeObject: child)] - inSmalltalk: [self assertValidFreeObject: child]. - childBytes := self bytesInObject: child. - childBytes = chunkBytes - ifTrue: "size match; try to remove from list at node first." - [node := child. - [prev := node. - node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. - node ~= 0] whileTrue: - [(acceptanceBlock value: node) ifTrue: - [self assert: (self isValidFreeObject: node). - self - setNextFreeChunkOf: prev - withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) - bytesBigEnoughForPrevPointer: true. - totalFreeOldSpace := totalFreeOldSpace - chunkBytes. - ^self startOfObject: node]]. - (acceptanceBlock value: child) ifFalse: - [^nil]. "node was right size but unaceptable." - next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. - next = 0 - ifTrue: "no list; remove the interior node" - [self unlinkSolitaryFreeTreeNode: child] - ifFalse: "list; replace node with it" - [self inFreeTreeReplace: child with: next]. - totalFreeOldSpace := totalFreeOldSpace - chunkBytes. - ^self startOfObject: child] - ifFalse: "no size match; walk down the tree" - [child := self fetchPointer: (childBytes < chunkBytes - ifTrue: [self freeChunkLargerIndex] - ifFalse: [self freeChunkSmallerIndex]) - ofFreeChunk: child]]. - ^nil! Item was changed: ----- Method: SpurMemoryManager>>isValidFreeObject: (in category 'free space') ----- isValidFreeObject: objOop | chunk | ^(self addressCouldBeOldObj: objOop) and: [(self isFreeObject: objOop) and: [(self oop: (self addressAfter: objOop) isLessThanOrEqualTo: endOfMemory) and: [((chunk := (self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop)) = 0 or: [self isFreeOop: chunk]) + and: [ + (self bytesBigEnoughForPrevPointer: (self bytesInObject: objOop)) not + or: [((chunk := (self fetchPointer: self freeChunkPrevIndex ofFreeChunk: objOop)) = 0 + or: [self isFreeOop: chunk]) - and: [((chunk := (self fetchPointer: self freeChunkPrevIndex ofFreeChunk: objOop)) = 0 - or: [self isFreeOop: chunk]) and: [(self isLargeFreeObject: objOop) not or: [((chunk := (self fetchPointer: self freeChunkParentIndex ofFreeChunk: objOop)) = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]) and: [((chunk := (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: objOop)) = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]) and: [(chunk := (self fetchPointer: self freeChunkLargerIndex ofFreeChunk: objOop)) = 0 + or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]]]]]]]]]]! - or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]]]]]]]]]! Item was removed: - ----- Method: SpurMemoryManager>>unlinkFreeChunk:atIndex: (in category 'free space') ----- - unlinkFreeChunk: chunk atIndex: index - "Unlink and answer a small chunk from one of the fixed size freeLists" - <inline: true> - |next| - self assert: ((self bytesInObject: chunk) = (index * self allocationUnit) - and: [index > 1 "a.k.a. (self bytesInObject: chunk) > self allocationUnit" - and: [(self startOfObject: chunk) = chunk]]). - freeLists - at: index - put: (next := self - fetchPointer: self freeChunkNextIndex - ofFreeChunk: chunk). - next = 0 ifFalse: [self storePointer: self freeChunkPrevIndex ofFreeChunk: next withValue: 0]. - ^chunk! Item was added: + ----- Method: SpurMemoryManager>>unlinkFreeChunk:atIndex:chunkBytes: (in category 'free space') ----- + unlinkFreeChunk: chunk atIndex: index chunkBytes: chunkBytes + "Unlink and answer a small chunk from one of the fixed size freeLists" + <inline: true> + |next| + self assert: ((self bytesInObject: chunk) = (index * self allocationUnit) + and: [index > 1 "a.k.a. (self bytesInObject: chunk) > self allocationUnit" + and: [(self startOfObject: chunk) = chunk]]). + freeLists + at: index + put: (next := self + fetchPointer: self freeChunkNextIndex + ofFreeChunk: chunk). + ((self bytesBigEnoughForPrevPointer: chunkBytes) and: [next ~= 0]) ifTrue: + [self storePointer: self freeChunkPrevIndex ofFreeChunk: next withValue: 0]. + ^chunk! Item was changed: ----- Method: SpurMemoryManager>>unlinkFreeChunk:chunkBytes: (in category 'free space') ----- unlinkFreeChunk: freeChunk chunkBytes: chunkBytes "Unlink a free object from the free lists. Do not alter totalFreeOldSpace. Used for coalescing." | index node next prev | index := chunkBytes / self allocationUnit. "Pathological 64 bits case - size 1 - single linked list" (self bytesBigEnoughForPrevPointer: chunkBytes) ifFalse: [node := freeLists at: index. prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. node = freeChunk ifTrue: [prev = 0 + ifTrue: [self unlinkFreeChunk: freeChunk atIndex: index chunkBytes: chunkBytes] - ifTrue: [freeLists at: index put: next] ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. ^self]. prev := node. node := next]. self error: 'freeChunk not found in free list of size 1']. prev := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: freeChunk. "Has prev element: update double linked list" prev ~= 0 ifTrue: [self setNextFreeChunkOf: prev withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk) chunkBytes: chunkBytes. ^self]. "Is the beginning of a list" "Small chunk" (index < self numFreeLists and: [1 << index <= freeListsMask]) ifTrue: [ + ^self unlinkFreeChunk: freeChunk atIndex: index chunkBytes: chunkBytes]. - ^self unlinkFreeChunk: freeChunk atIndex: index]. "Large chunk" next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: freeChunk] ifFalse: "list; replace node with it" [self inFreeTreeReplace: freeChunk with: next] ! Item was changed: ----- Method: SpurMemoryManager>>updateListStartingAt: (in category 'initialization') ----- updateListStartingAt: freeNode |prev obj| + freeNode = 0 ifTrue: [^self]. + self assert: (self bytesBigEnoughForPrevPointer: (self bytesInObject: freeNode)). prev := freeNode. self storePointer: self freeChunkPrevIndex ofFreeChunk: prev withValue: 0. [obj := self fetchPointer: self freeChunkNextIndex ofFreeChunk: prev. obj ~= 0] whileTrue: [self storePointer: self freeChunkPrevIndex ofFreeChunk: obj withValue: prev. prev := obj]!

1 0

VM Maker: VMMaker.oscog-cb.2406.mcz
by commits＠source.squeak.org 07 Jun '18

07 Jun '18

ClementBera uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-cb.2406.mcz ==================== Summary ==================== Name: VMMaker.oscog-cb.2406 Author: cb Time: 7 June 2018, 8:02:40.687927 pm UUID: f05a0c4e-15d4-44ab-8ac2-333a6ac1577c Ancestors: VMMaker.oscog-cb.2405 Added bytesBigEnoughForPrevPointer: abstraction and patch all callers to use that. 32 bits works, now fixing 64 bits. =============== Diff against VMMaker.oscog-cb.2405 =============== Item was added: + ----- Method: Spur32BitMemoryManager>>bytesBigEnoughForPrevPointer: (in category 'free space') ----- + bytesBigEnoughForPrevPointer: chunkBytes + "Allocation unit, the minimum size, is enough for 2 pointers" + ^ true! Item was added: + ----- Method: Spur64BitMemoryManager>>bytesBigEnoughForPrevPointer: (in category 'free space') ----- + bytesBigEnoughForPrevPointer: chunkBytes + ^ chunkBytes ~= (self baseHeaderSize + self allocationUnit)! Item was changed: ----- Method: SpurMemoryManager>>addToFreeTree:bytes: (in category 'free space') ----- addToFreeTree: freeChunk bytes: chunkBytes "Add freeChunk to the large free chunk tree. For the benefit of sortedFreeObject:, answer the treeNode it is added to, if it is added to the next list of a freeTreeNode, otherwise answer 0." | childBytes parent child | self assert: (self isFreeObject: freeChunk). self assert: chunkBytes = (self bytesInObject: freeChunk). self assert: chunkBytes >= (self numFreeLists * self allocationUnit). self storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkSmallerIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkLargerIndex ofFreeChunk: freeChunk withValue: 0. "Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks." parent := 0. child := freeLists at: 0. [child ~= 0] whileTrue: [childBytes := self bytesInObject: child. "check for overlap; could write this as self oop: (self objectAfter: freeChunk) isLessThanOrEqualTo: child... but that relies on headers being correct, etc. So keep it clumsy..." self assert: ((self oop: freeChunk + chunkBytes - self baseHeaderSize isLessThanOrEqualTo: child) or: [self oop: freeChunk isGreaterThanOrEqualTo: child + childBytes - self baseHeaderSize]). childBytes = chunkBytes ifTrue: "size match; add to list at node." + [self setNextFreeChunkOf: freeChunk withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: child) bytesBigEnoughForPrevPointer: true. + self setNextFreeChunkOf: child withValue: freeChunk bytesBigEnoughForPrevPointer: true. - [self setNextFreeChunkOf: freeChunk withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: child) sizeIsOne: false. - self setNextFreeChunkOf: child withValue: freeChunk sizeIsOne: false. ^child]. "walk down the tree" parent := child. child := self fetchPointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: child]. parent = 0 ifTrue: [self assert: (freeLists at: 0) = 0. freeLists at: 0 put: freeChunk. freeListsMask := freeListsMask bitOr: 1. ^0]. self assert: (freeListsMask anyMask: 1). "insert in tree" self storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: parent. self storePointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: parent withValue: freeChunk. ^0! Item was changed: ----- Method: SpurMemoryManager>>allocateLargestFreeChunk (in category 'free space') ----- allocateLargestFreeChunk "Answer the largest free chunk in the free lists." <inline: false> | freeChunk next | "would like to use ifNotNil: but the ^next inside the ^blah ifNotNil: confused Slang" freeChunk := self findLargestFreeChunk. freeChunk ifNil: [^nil]. "This will be the node, not a list element. Answer a list element in preference." next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk. next ~= 0 ifTrue: [self assert: (self bytesInObject: freeChunk) >= self numFreeLists. "findLargestFreeChunk searches only the tree" self setNextFreeChunkOf: freeChunk withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: next) + bytesBigEnoughForPrevPointer: true. - sizeIsOne: false. ^next]. self unlinkSolitaryFreeTreeNode: freeChunk. ^freeChunk! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfBytes: (in category 'free space') ----- allocateOldSpaceChunkOfBytes: chunkBytes "Answer a chunk of oldSpace from the free lists, if available, otherwise answer nil. Break up a larger chunk if one of the exact size does not exist. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | initialIndex chunk index nodeBytes parent child | "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)" initialIndex := chunkBytes / self allocationUnit. (initialIndex < self numFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue: [(freeListsMask anyMask: 1 << initialIndex) ifTrue: [(chunk := freeLists at: initialIndex) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assert: (self isValidFreeObject: chunk). ^self unlinkFreeChunk: chunk atIndex: initialIndex]. freeListsMask := freeListsMask - (1 << initialIndex)]. "first search for free chunks of a multiple of chunkBytes in size" index := initialIndex. [(index := index + index) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(chunk := freeLists at: index) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assert: (self isValidFreeObject: chunk). self unlinkFreeChunk: chunk atIndex: index. self assert: (self bytesInObject: chunk) = (index * self allocationUnit). self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: chunk) + chunkBytes. ^chunk]. freeListsMask := freeListsMask - (1 << index)]]. "now get desperate and use the first that'll fit. Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence start at initialIndex + 2." index := initialIndex + 1. [(index := index + 1) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(chunk := freeLists at: index) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assert: (self isValidFreeObject: chunk). self unlinkFreeChunk: chunk atIndex: index. self assert: (self bytesInObject: chunk) = (index * self allocationUnit). self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: chunk) + chunkBytes. ^chunk]. freeListsMask := freeListsMask - (1 << index)]]]. "Large chunk, or no space on small free lists. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the smallest chunk at least as large as chunkBytes, or 0 if none." parent := 0. child := freeLists at: 0. [child ~= 0] whileTrue: [| childBytes | self assert: (self isValidFreeObject: child). childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. chunk ~= 0 ifTrue: [self assert: (self isValidFreeObject: chunk). self setNextFreeChunkOf: child withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk) + bytesBigEnoughForPrevPointer: true. - sizeIsOne: false. ^self startOfObject: chunk]. nodeBytes := childBytes. parent := child. child := 0] "break out of loop to remove interior node" ifFalse: ["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger." childBytes <= (chunkBytes + self allocationUnit) ifTrue: "node too small; walk down the larger size of the tree" [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child] ifFalse: [parent := child. "parent will be smallest node >= chunkBytes + allocationUnit" nodeBytes := childBytes. child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]]. parent = 0 ifTrue: [totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded" ^nil]. "self printFreeChunk: parent" self assert: (nodeBytes = chunkBytes or: [nodeBytes >= (chunkBytes + (2 * self allocationUnit))]). self assert: (self bytesInObject: parent) = nodeBytes. "attempt to remove from list" chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: parent. chunk ~= 0 ifTrue: [self assert: (chunkBytes = nodeBytes or: [chunkBytes + self allocationUnit < nodeBytes]). self setNextFreeChunkOf: parent withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk) + bytesBigEnoughForPrevPointer: true. - sizeIsOne: false. chunkBytes ~= nodeBytes ifTrue: [self freeChunkWithBytes: nodeBytes - chunkBytes at: (self startOfObject: chunk) + chunkBytes]. ^self startOfObject: chunk]. "no list; remove the interior node" chunk := parent. self unlinkSolitaryFreeTreeNode: chunk. "if there's space left over, add the fragment back." chunkBytes ~= nodeBytes ifTrue: [self freeChunkWithBytes: nodeBytes - chunkBytes at: (self startOfObject: chunk) + chunkBytes]. ^self startOfObject: chunk! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfBytes:suchThat: (in category 'free space') ----- allocateOldSpaceChunkOfBytes: chunkBytes suchThat: acceptanceBlock "Answer a chunk of oldSpace from the free lists that satisfies acceptanceBlock, if available, otherwise answer nil. Break up a larger chunk if one of the exact size cannot be found. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | initialIndex node next prev index child childBytes acceptedChunk acceptedNode | <inline: true> "must inline for acceptanceBlock" "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)" initialIndex := chunkBytes / self allocationUnit. (initialIndex < self numFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue: [(freeListsMask anyMask: 1 << initialIndex) ifTrue: [(node := freeLists at: initialIndex) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << initialIndex)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [freeLists at: initialIndex put: next] ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. ^node]. prev := node. node := next]]]. "first search for free chunks of a multiple of chunkBytes in size" index := initialIndex. [(index := index + initialIndex) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << index)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [freeLists at: index put: next] ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: node) + chunkBytes. ^node]. prev := node. node := next]]]]. "now get desperate and use the first that'll fit. Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence start at initialIndex + 2." index := initialIndex + 1. [(index := index + 1) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << index)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [freeLists at: index put: next] ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: node) + chunkBytes. ^node]. prev := node. node := next]]]]]. "Large chunk, or no space on small free lists. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the smallest chunk at least as large as chunkBytes, or 0 if none. acceptedChunk and acceptedNode save us from having to back-up when the acceptanceBlock filters-out all nodes of the right size, but there are nodes of the wrong size it does accept." child := freeLists at: 0. node := acceptedChunk := acceptedNode := 0. [child ~= 0] whileTrue: [self assert: (self isValidFreeObject: child). childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [node := child. [prev := node. node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. node ~= 0] whileTrue: [(acceptanceBlock value: node) ifTrue: [self assert: (self isValidFreeObject: node). + self + setNextFreeChunkOf: prev + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) + bytesBigEnoughForPrevPointer: true. - self setNextFreeChunkOf: prev withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) sizeIsOne: false. ^self startOfObject: node]]. (acceptanceBlock value: child) ifTrue: [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: child] ifFalse: "list; replace node with it" [self inFreeTreeReplace: child with: next]. ^self startOfObject: child]]. child ~= 0 ifTrue: ["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger." childBytes <= (chunkBytes + self allocationUnit) ifTrue: "node too small; walk down the larger size of the tree" [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child] ifFalse: [self flag: 'we can do better here; preferentially choosing the lowest node. That would be a form of best-fit since we are trying to compact down'. node := child. child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node. acceptedNode = 0 ifTrue: [acceptedChunk := node. "first search the list." [acceptedChunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk. (acceptedChunk ~= 0 and: [acceptanceBlock value: acceptedChunk]) ifTrue: [acceptedNode := node]. acceptedChunk ~= 0 and: [acceptedNode = 0]] whileTrue. "nothing on the list; will the node do? This prefers acceptable nodes higher up the tree over acceptable list elements further down, but we haven't got all day..." (acceptedNode = 0 and: [acceptanceBlock value: node]) ifTrue: [acceptedNode := node. child := 0 "break out of loop now we have an acceptedNode"]]]]]. acceptedNode ~= 0 ifTrue: [acceptedChunk ~= 0 ifTrue: [self assert: (self bytesInObject: acceptedChunk) >= (chunkBytes + self allocationUnit). [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode. next ~= acceptedChunk] whileTrue: [acceptedNode := next]. self setNextFreeChunkOf: acceptedNode withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk) + bytesBigEnoughForPrevPointer: true. - sizeIsOne: false. self freeChunkWithBytes: (self bytesInObject: acceptedChunk) - chunkBytes at: (self startOfObject: acceptedChunk) + chunkBytes. ^self startOfObject: acceptedChunk]. next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: acceptedNode] ifFalse: "list; replace node with it" [self inFreeTreeReplace: acceptedNode with: next]. self assert: (self bytesInObject: acceptedNode) >= (chunkBytes + self allocationUnit). self freeChunkWithBytes: (self bytesInObject: acceptedNode) - chunkBytes at: (self startOfObject: acceptedNode) + chunkBytes. ^self startOfObject: acceptedNode]. totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded" ^nil! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes: (in category 'free space') ----- allocateOldSpaceChunkOfExactlyBytes: chunkBytes "Answer a chunk of oldSpace from the free lists, if one of this size is available, otherwise answer nil. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | index node child | "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) ~= 0 ifTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self unlinkFreeChunk: node atIndex: index]. freeListsMask := freeListsMask - (1 << index)]. ^nil]. "Large chunk. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the first chunk of the same size as chunkBytes, or 0 if none." child := freeLists at: 0. [child ~= 0] whileTrue: [| childBytes | self assert: (self isValidFreeObject: child). childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. node ~= 0 ifTrue: [self assert: (self isValidFreeObject: node). self setNextFreeChunkOf: child withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) + bytesBigEnoughForPrevPointer: true. - sizeIsOne: false. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: node]. "nothing acceptable on node's list; answer the node." self unlinkSolitaryFreeTreeNode: child. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: child] ifFalse: [child := self fetchPointer: (childBytes < chunkBytes ifTrue: [self freeChunkLargerIndex] ifFalse: [self freeChunkSmallerIndex]) ofFreeChunk: child]]. ^nil! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes:suchThat: (in category 'free space') ----- allocateOldSpaceChunkOfExactlyBytes: chunkBytes suchThat: acceptanceBlock "Answer a chunk of oldSpace from the free lists that satisfies acceptanceBlock, if one of this size is available, otherwise answer nil. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | index node next prev child childBytes | <inline: true> "must inline for acceptanceBlock" "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << index)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [freeLists at: index put: next] ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^node]. prev := node. node := next]]]. ^nil]. "Large chunk. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the first chunk of the same size as chunkBytes, or 0 if none." node := 0. child := freeLists at: 0. [child ~= 0] whileTrue: [self "Sorry stepping over isValidFreeObject all the time was killing me" cCode: [self assert: (self isValidFreeObject: child)] inSmalltalk: [self assertValidFreeObject: child]. childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node first." [node := child. [prev := node. node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. node ~= 0] whileTrue: [(acceptanceBlock value: node) ifTrue: [self assert: (self isValidFreeObject: node). self setNextFreeChunkOf: prev withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) + bytesBigEnoughForPrevPointer: true. - sizeIsOne: false. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: node]]. (acceptanceBlock value: child) ifFalse: [^nil]. "node was right size but unaceptable." next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: child] ifFalse: "list; replace node with it" [self inFreeTreeReplace: child with: next]. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: child] ifFalse: "no size match; walk down the tree" [child := self fetchPointer: (childBytes < chunkBytes ifTrue: [self freeChunkLargerIndex] ifFalse: [self freeChunkSmallerIndex]) ofFreeChunk: child]]. ^nil! Item was changed: ----- Method: SpurMemoryManager>>assertValidFreeObject: (in category 'free space') ----- assertValidFreeObject: objOop <doNotGenerate> "If you want to generate this you want to use 'self assert: (self isValidFreeObject: objOop)' instead not to generate code in assertion-free VMs" | chunk | "duplicated assertions from isValidFreeObject: because I need to know what is wrong not only that it is not valid (I got bored of stepping inside isValidFreeObject:...)" self assert: (self oop: (self addressAfter: objOop) isLessThanOrEqualTo: endOfMemory). chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [self isFreeOop: chunk]). + (self bytesBigEnoughForPrevPointer: (self bytesInObject: objOop)) ifTrue: - (self bytesInObject: objOop) / self wordSize = 1 ifFalse: ["double linkedlist assertions" chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop. chunk = 0 ifFalse: [self assert: (self isFreeOop: chunk). self assert: objOop = (self fetchPointer: self freeChunkPrevIndex ofFreeChunk: chunk)]. chunk := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: objOop. chunk = 0 ifFalse: [self assert: (self isFreeOop: chunk). self assert: objOop = (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk)].]. (self isLargeFreeObject: objOop) ifTrue: ["Tree assertions" chunk := self fetchPointer: self freeChunkParentIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). chunk := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). chunk := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). ]! Item was added: + ----- Method: SpurMemoryManager>>bytesBigEnoughForPrevPointer: (in category 'free space') ----- + bytesBigEnoughForPrevPointer: chunkBytes + self subclassResponsibility! Item was changed: ----- Method: SpurMemoryManager>>checkHeapFreeSpaceIntegrity (in category 'debug support') ----- checkHeapFreeSpaceIntegrity "Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccessibleFreeSpace has set a bit at each free chunk's header. Scan all objects in the heap checking that no pointer points to a free chunk and that all free chunks that refer to others refer to marked chunks. Answer if all checks pass." | ok total | <inline: false> <var: 'total' type: #usqInt> ok := true. total := 0. 0 to: self numFreeLists - 1 do: [:i| (freeLists at: i) ~= 0 ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) = 0 ifTrue: [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); cr. self eek. ok := false]]]. "Excuse the duplication but performance is at a premium and we avoid some tests by splitting the newSpace and oldSpace enumerations." self allNewSpaceEntitiesDo: [:obj| | fieldOop | (self isFreeObject: obj) ifTrue: [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; cr. self eek. ok := false] ifFalse: [0 to: (self numPointerSlotsOf: obj) - 1 do: [:fi| fieldOop := self fetchPointer: fi ofObject: obj. (self isNonImmediate: fieldOop) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; cr. self eek. ok := false]]]]]. self allOldSpaceEntitiesDo: [:obj| | fieldOop | (self isFreeObject: obj) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is unmapped?!! '; cr. self eek. ok := false]. fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr. self eek. ok := false]. + (self bytesBigEnoughForPrevPointer: (self bytesInObject: obj)) ifTrue: - (self bytesInObject: obj) / self wordSize = 1 ifFalse: [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr. self eek. ok := false]]. (self isLargeFreeObject: obj) ifTrue: [self freeChunkParentIndex to: self freeChunkLargerIndex do: [:fi| fieldOop := self fetchPointer: fi ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is unmapped'; cr. self eek. ok := false]]]. total := total + (self bytesInObject: obj)] ifFalse: [0 to: (self numPointerSlotsOf: obj) - 1 do: [:fi| (self isForwarded: obj) ifTrue: [self assert: fi = 0. "I'm now trying to use forwarders in GC algorithms..." fieldOop := self fetchPointer: fi ofMaybeForwardedObject: obj] ifFalse: "We keep #fetchPointer:ofObject: API here for assertions" [fieldOop := self fetchPointer: fi ofObject: obj]. (self isNonImmediate: fieldOop) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; cr. self eek. ok := false]]]]]. total ~= totalFreeOldSpace ifTrue: [coInterpreter print: 'incorrect totalFreeOldSpace; expected '; printNum: totalFreeOldSpace; print: ' found '; printNum: total; cr. self eek. ok := false]. ^ok! Item was changed: ----- Method: SpurMemoryManager>>checkHeapIntegrity:classIndicesShouldBeValid: (in category 'debug support') ----- checkHeapIntegrity: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid "Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccessibleObjects has set a bit at each (non-free) object's header. Scan all objects in the heap checking that every pointer points to a header. Scan the rememberedSet, remapBuffer and extraRootTable checking that every entry is a pointer to a header. Check that the number of roots is correct and that all rememberedSet entries have their isRemembered: flag set. Answer if all checks pass." | ok numRememberedObjectsInHeap | <inline: false> self cCode: [] inSmalltalk: ["Almost all of the time spent here used to go into the asserts in fetchPointer:ofObject: in the simulator class overrides. Since we know here the indices used are valid we temporarily remove them to claw back that performance." (self class whichClassIncludesSelector: #fetchPointer:ofObject:) ~= SpurMemoryManager ifTrue: [^self withSimulatorFetchPointerMovedAsideDo: [self checkHeapIntegrity: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid]]]. ok := true. numRememberedObjectsInHeap := 0. 0 to: self numFreeLists - 1 do: [:i| (freeLists at: i) ~= 0 ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) ~= 0 ifTrue: [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); cr. self eek. ok := false]]]. "Excuse the duplication but performance is at a premium and we avoid some tests by splitting the newSpace and oldSpace enumerations." self allNewSpaceEntitiesDo: [:obj| | fieldOop classIndex classOop | (self isFreeObject: obj) ifTrue: [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; cr. self eek. ok := false] ifFalse: [((self isMarked: obj) not and: [excludeUnmarkedObjs]) ifFalse: [(self isRemembered: obj) ifTrue: [coInterpreter print: 'young object '; printHex: obj; print: ' is remembered'; cr. self eek. ok := false]]. (self isForwarded: obj) ifTrue: [fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj. (heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue: [coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr. self eek. ok := false]] ifFalse: [classOop := self classOrNilAtIndex: (classIndex := self classIndexOf: obj). (classIndicesShouldBeValid and: [classOop = nilObj and: [(self isHiddenObj: obj) not]]) ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr. self eek. ok := false]. 0 to: (self numPointerSlotsOf: obj) - 1 do: [:fi| fieldOop := self fetchPointer: fi ofObject: obj. (self isNonImmediate: fieldOop) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr. self eek. ok := false]]]]]]. self allOldSpaceEntitiesDo: [:obj| | containsYoung fieldOop classIndex classOop | (self isFreeObject: obj) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0 ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is mapped?!! '; cr. self eek. ok := false]. fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is mapped'; cr. self eek. ok := false]. + (self bytesBigEnoughForPrevPointer: (self bytesInObject: obj)) ifTrue: - (self bytesInObject: obj) / self wordSize = 1 ifFalse: [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr. self eek. ok := false]]. (self isLargeFreeObject: obj) ifTrue: [self freeChunkParentIndex to: self freeChunkLargerIndex do: [:fi| fieldOop := self fetchPointer: fi ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is mapped'; cr. self eek. ok := false].]]] ifFalse: [(excludeUnmarkedObjs and: [(self isMarked: obj)not]) ifTrue: [] ifFalse: [ containsYoung := false. (self isRemembered: obj) ifTrue: [numRememberedObjectsInHeap := numRememberedObjectsInHeap + 1. (scavenger isInRememberedSet: obj) ifFalse: [coInterpreter print: 'remembered object '; printHex: obj; print: ' is not in remembered table'; cr. self eek. ok := false]]. (self isForwarded: obj) ifTrue: [fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj. (heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue: [coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr. self eek. ok := false]. (self isReallyYoung: fieldOop) ifTrue: [containsYoung := true]] ifFalse: [classOop := self classOrNilAtIndex: (classIndex := self classIndexOf: obj). (classIndicesShouldBeValid and: [classOop = nilObj and: [classIndex > self lastClassIndexPun]]) ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr. self eek. ok := false]. 0 to: (self numPointerSlotsOf: obj) - 1 do: [:fi| fieldOop := self fetchPointer: fi ofObject: obj. (self isNonImmediate: fieldOop) ifTrue: [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr. self eek. ok := false]. "don't be misled by CogMethods; they appear to be young, but they're not" (self isReallyYoung: fieldOop) ifTrue: [containsYoung := true]]]]. containsYoung ifTrue: [(self isRemembered: obj) ifFalse: [coInterpreter print: 'unremembered object '; printHex: obj; print: ' contains young oop(s)'; cr. self eek. ok := false]]]]]. numRememberedObjectsInHeap ~= scavenger rememberedSetSize ifTrue: [coInterpreter print: 'root count mismatch. #heap roots '; printNum: numRememberedObjectsInHeap; print: '; #roots '; printNum: scavenger rememberedSetSize; cr. self eek. "But the system copes with overflow..." self flag: 'no support for remembered set overflow yet'. "ok := rootTableOverflowed and: [needGCFlag]"]. scavenger rememberedSetWithIndexDo: [:obj :i| (obj bitAnd: self wordSize - 1) ~= 0 ifTrue: [coInterpreter print: 'misaligned oop in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr. self eek. ok := false] ifFalse: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'object leak in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr. self eek. ok := false] ifFalse: [(self isYoung: obj) ifTrue: [coInterpreter print: 'non-root in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr. self eek. ok := false]]]]. self objStack: mournQueue do: [:i :page| | obj | obj := self fetchPointer: i ofObject: page. (obj bitAnd: self wordSize - 1) ~= 0 ifTrue: [coInterpreter print: 'misaligned oop in mournQueue @ '; printNum: i; print: ' in '; printHex: page; print: ' = '; printHex: obj; cr. self eek. ok := false] ifFalse: [(excludeUnmarkedObjs and: [(self isMarked: obj) not]) ifFalse: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'object leak in mournQueue @ '; printNum: i; print: ' in '; printHex: page; print: ' = '; printHex: obj; cr. self eek. ok := false]]]]. 1 to: remapBufferCount do: [:ri| | obj | obj := remapBuffer at: ri. (obj bitAnd: self wordSize - 1) ~= 0 ifTrue: [coInterpreter print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr. self eek. ok := false] ifFalse: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr. self eek. ok := false]]]. 1 to: extraRootCount do: [:ri| | obj | obj := (extraRoots at: ri) at: 0. (obj bitAnd: self wordSize - 1) ~= 0 ifTrue: [coInterpreter print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr. self eek. ok := false] ifFalse: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr. self eek. ok := false]]]. ^ok! Item was added: + ----- Method: SpurMemoryManager>>setNextFreeChunkOf:withValue:bytesBigEnoughForPrevPointer: (in category 'free space') ----- + setNextFreeChunkOf: freeChunk withValue: nextFreeChunk bytesBigEnoughForPrevPointer: bytesBigEnoughForPrevPointer + <inline: true> "Inlining is quite important since bytesBigEnoughForPrevPointer is often true" + self + storePointer: self freeChunkNextIndex + ofFreeChunk: freeChunk + withValue: nextFreeChunk. + (nextFreeChunk ~= 0 and: [bytesBigEnoughForPrevPointer]) ifTrue: + [self + storePointer: self freeChunkPrevIndex + ofFreeChunk: nextFreeChunk + withValue: freeChunk] + + ! Item was changed: ----- Method: SpurMemoryManager>>setNextFreeChunkOf:withValue:chunkBytes: (in category 'free space') ----- setNextFreeChunkOf: freeChunk withValue: nextFreeChunk chunkBytes: chunkBytes - <inline: true> self setNextFreeChunkOf: freeChunk withValue: nextFreeChunk + bytesBigEnoughForPrevPointer: (self bytesBigEnoughForPrevPointer: chunkBytes) - sizeIsOne: chunkBytes / self wordSize = 1 ! Item was removed: - ----- Method: SpurMemoryManager>>setNextFreeChunkOf:withValue:sizeIsOne: (in category 'free space') ----- - setNextFreeChunkOf: freeChunk withValue: nextFreeChunk sizeIsOne: sizeIsOne - <inline: true> "Inlining is quite important since sizeIsOne is often false" - self - storePointer: self freeChunkNextIndex - ofFreeChunk: freeChunk - withValue: nextFreeChunk. - "In 32 bits, there's always enough room, - in 64 bits, size 1 is special." - (nextFreeChunk = 0 or: [sizeIsOne]) ifFalse: - [self - storePointer: self freeChunkPrevIndex - ofFreeChunk: nextFreeChunk - withValue: freeChunk] - - ! Item was changed: ----- Method: SpurMemoryManager>>swizzleFieldsOfFreeChunk: (in category 'snapshot') ----- swizzleFieldsOfFreeChunk: chunk <inline: true> | field chunkBytes | field := self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk. field ~= 0 ifTrue: [self storePointerNoAssert: self freeChunkNextIndex ofFreeChunk: chunk withValue: (segmentManager swizzleObj: field)]. + (self bytesBigEnoughForPrevPointer: (chunkBytes := self bytesInObject: chunk)) ifTrue: - (chunkBytes := self bytesInObject: chunk) / self wordSize = 1 ifFalse: [field := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: chunk. field ~= 0 ifTrue: [self storePointerNoAssert: self freeChunkPrevIndex ofFreeChunk: chunk withValue: (segmentManager swizzleObj: field)]]. chunkBytes >= (self numFreeLists * self allocationUnit) ifTrue: [self freeChunkParentIndex to: self freeChunkLargerIndex do: [:index| field := self fetchPointer: index ofFreeChunk: chunk. field ~= 0 ifTrue: [self storePointerNoAssert: index ofFreeChunk: chunk withValue: (segmentManager swizzleObj: field)]]]! Item was changed: ----- Method: SpurMemoryManager>>unlinkFreeChunk:chunkBytes: (in category 'free space') ----- unlinkFreeChunk: freeChunk chunkBytes: chunkBytes "Unlink a free object from the free lists. Do not alter totalFreeOldSpace. Used for coalescing." | index node next prev | index := chunkBytes / self allocationUnit. "Pathological 64 bits case - size 1 - single linked list" + + (self bytesBigEnoughForPrevPointer: chunkBytes) ifFalse: - chunkBytes / self wordSize = 1 ifTrue: [node := freeLists at: index. prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. node = freeChunk ifTrue: [prev = 0 ifTrue: [freeLists at: index put: next] ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. ^self]. prev := node. node := next]. self error: 'freeChunk not found in free list of size 1']. prev := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: freeChunk. "Has prev element: update double linked list" prev ~= 0 ifTrue: [self setNextFreeChunkOf: prev withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk) chunkBytes: chunkBytes. ^self]. "Is the beginning of a list" "Small chunk" (index < self numFreeLists and: [1 << index <= freeListsMask]) ifTrue: [ ^self unlinkFreeChunk: freeChunk atIndex: index]. "Large chunk" next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: freeChunk] ifFalse: "list; replace node with it" [self inFreeTreeReplace: freeChunk with: next] ! Item was changed: ----- Method: SpurMemoryManager>>updateFreeLists (in category 'initialization') ----- updateFreeLists "Snapshot did not guarantee the state of the freelist prevLink, so we need to update it. Effectively transforms the freechunk single linked list in double linked list." |min| "Small chunks" "Skip in 64 bits size 1 which is single linked list - pathological case" + self wordSize = 8 ifTrue: [min := 2] ifFalse: [min := 1]. - self allocationUnit / self wordSize = 1 ifTrue: [min := 2] ifFalse: [min := 1]. min to: self numFreeLists - 1 do: [:i| self updateListStartingAt: (freeLists at: i)]. "Large chunks" self freeTreeNodesDo: [:freeNode | self updateListStartingAt: freeNode. freeNode]!

1 0

VM Maker: VMMaker.oscog-cb.2405.mcz
by commits＠source.squeak.org 07 Jun '18

07 Jun '18

ClementBera uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-cb.2405.mcz ==================== Summary ==================== Name: VMMaker.oscog-cb.2405 Author: cb Time: 7 June 2018, 4:16:07.513295 pm UUID: 5452dde0-de82-486b-bb11-dfd115dcb8be Ancestors: VMMaker.oscog-eem.2404 - changed the free list representation from linked list to double linked list to unlink efficiently the free chunk in compaction phases. - Fix some simulation details - cheated a bit some simulation of VM profiling - Removed Pig compactor (Incompatible with the new double linked list scheme) - a few more simulation assertion on freeTreeOverlap I have not tested yet code generation, testing right now =============== Diff against VMMaker.oscog-eem.2404 =============== Item was changed: ----- Method: CogClass>>cCoerceSimple:to: (in category 'translation support') ----- cCoerceSimple: value to: cTypeString <doNotGenerate> "Type coercion for translation and simulation. For simulation answer a suitable surrogate for the struct types" ^cTypeString caseOf: { [#'unsigned long'] -> [value]. [#'unsigned int'] -> [value]. [#'unsigned short'] -> [value]. [#sqInt] -> [value]. [#'sqIntptr_t'] -> [value]. [#'usqIntptr_t'] -> [value]. [#usqInt] -> [value]. [#sqLong] -> [value]. [#usqLong] -> [value]. [#'AbstractInstruction *'] -> [value]. + [#'SpurSegmentInfo *'] -> [value]. [#'BytecodeFixup *'] -> [value]. [#'CogMethod *'] -> [value]. [#'char *'] -> [value]. [#'sqInt *'] -> [value]. [#'void *'] -> [value]. [#void] -> [value]. [#'void (*)()'] -> [value]. [#'void (*)(void)'] -> [value]. [#'unsigned long (*)(void)'] -> [value]. [#'void (*)(unsigned long,unsigned long)'] -> [value]. [#'usqIntptr_t (*)(void)'] -> [value] }! Item was changed: ----- Method: InterpreterPrimitives>>primitiveControlVMProfiling (in category 'process primitives') ----- primitiveControlVMProfiling "Primitive. Start or stop the VM profiler. The first argument is a boolean to switch profiling on or off. The second argument is an integer or nil. If an integer it determines the maximum number of samples in the VM's sample buffer. Answer the current number of samples in the buffer." | onOffBar bufferSize numSamples | argumentCount ~= 2 ifTrue: [^self primitiveFail]. (onOffBar := self stackValue: 1) = objectMemory trueObject ifTrue: [onOffBar := 1] ifFalse: [onOffBar = objectMemory falseObject ifTrue: [onOffBar := 0] ifFalse: [^self primitiveFail]]. (bufferSize := self stackTop) = objectMemory nilObject ifTrue: [bufferSize := 0] ifFalse: [((objectMemory isIntegerObject: bufferSize) and: [(bufferSize := objectMemory integerValueOf: bufferSize) > 0]) ifFalse: [^self primitiveFail]]. + numSamples := self cCode: 'ioControlNewProfile(onOffBar,bufferSize)' inSmalltalk: [1667]. - numSamples := self cCode: 'ioControlNewProfile(onOffBar,bufferSize)'. self pop: 3 thenPushInteger: numSamples! Item was changed: ----- Method: SpurMemoryManager>>addToFreeList:bytes: (in category 'free space') ----- addToFreeList: freeChunk bytes: chunkBytes "Add freeChunk to the relevant freeList. For the benefit of sortedFreeObject:, if freeChunk is large, answer the treeNode it is added to, if it is added to the next list of a freeTreeNode, otherwise answer 0." | index | "coInterpreter transcript ensureCr. coInterpreter print: 'freeing '. self printFreeChunk: freeChunk." self assert: (self isFreeObject: freeChunk). self assert: chunkBytes = (self bytesInObject: freeChunk). index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: + [self setNextFreeChunkOf: freeChunk withValue: (freeLists at: index) chunkBytes: chunkBytes. + self storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0. - [self storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: (freeLists at: index). freeLists at: index put: freeChunk. freeListsMask := freeListsMask bitOr: 1 << index. ^0]. ^self addToFreeTree: freeChunk bytes: chunkBytes! Item was changed: ----- Method: SpurMemoryManager>>addToFreeTree:bytes: (in category 'free space') ----- addToFreeTree: freeChunk bytes: chunkBytes "Add freeChunk to the large free chunk tree. For the benefit of sortedFreeObject:, answer the treeNode it is added to, if it is added to the next list of a freeTreeNode, otherwise answer 0." | childBytes parent child | self assert: (self isFreeObject: freeChunk). self assert: chunkBytes = (self bytesInObject: freeChunk). self assert: chunkBytes >= (self numFreeLists * self allocationUnit). self storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: 0; + storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkSmallerIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkLargerIndex ofFreeChunk: freeChunk withValue: 0. "Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks." parent := 0. child := freeLists at: 0. [child ~= 0] whileTrue: [childBytes := self bytesInObject: child. "check for overlap; could write this as self oop: (self objectAfter: freeChunk) isLessThanOrEqualTo: child... but that relies on headers being correct, etc. So keep it clumsy..." self assert: ((self oop: freeChunk + chunkBytes - self baseHeaderSize isLessThanOrEqualTo: child) or: [self oop: freeChunk isGreaterThanOrEqualTo: child + childBytes - self baseHeaderSize]). childBytes = chunkBytes ifTrue: "size match; add to list at node." + [self setNextFreeChunkOf: freeChunk withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: child) sizeIsOne: false. + self setNextFreeChunkOf: child withValue: freeChunk sizeIsOne: false. - [self storePointer: self freeChunkNextIndex - ofFreeChunk: freeChunk - withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: child); - storePointer: self freeChunkNextIndex - ofFreeChunk: child - withValue: freeChunk. ^child]. "walk down the tree" parent := child. child := self fetchPointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: child]. parent = 0 ifTrue: [self assert: (freeLists at: 0) = 0. freeLists at: 0 put: freeChunk. freeListsMask := freeListsMask bitOr: 1. ^0]. self assert: (freeListsMask anyMask: 1). "insert in tree" self storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: parent. self storePointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: parent withValue: freeChunk. ^0! Item was changed: ----- Method: SpurMemoryManager>>allocateLargestFreeChunk (in category 'free space') ----- allocateLargestFreeChunk "Answer the largest free chunk in the free lists." <inline: false> | freeChunk next | "would like to use ifNotNil: but the ^next inside the ^blah ifNotNil: confused Slang" freeChunk := self findLargestFreeChunk. freeChunk ifNil: [^nil]. "This will be the node, not a list element. Answer a list element in preference." next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk. next ~= 0 ifTrue: + [self assert: (self bytesInObject: freeChunk) >= self numFreeLists. "findLargestFreeChunk searches only the tree" + self + setNextFreeChunkOf: freeChunk + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: next) + sizeIsOne: false. - [self storePointer: self freeChunkNextIndex - ofFreeChunk: freeChunk - withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: next). ^next]. self unlinkSolitaryFreeTreeNode: freeChunk. ^freeChunk! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfBytes: (in category 'free space') ----- allocateOldSpaceChunkOfBytes: chunkBytes "Answer a chunk of oldSpace from the free lists, if available, otherwise answer nil. Break up a larger chunk if one of the exact size does not exist. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | initialIndex chunk index nodeBytes parent child | "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)" initialIndex := chunkBytes / self allocationUnit. (initialIndex < self numFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue: [(freeListsMask anyMask: 1 << initialIndex) ifTrue: [(chunk := freeLists at: initialIndex) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assert: (self isValidFreeObject: chunk). ^self unlinkFreeChunk: chunk atIndex: initialIndex]. freeListsMask := freeListsMask - (1 << initialIndex)]. "first search for free chunks of a multiple of chunkBytes in size" index := initialIndex. [(index := index + index) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(chunk := freeLists at: index) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assert: (self isValidFreeObject: chunk). self unlinkFreeChunk: chunk atIndex: index. self assert: (self bytesInObject: chunk) = (index * self allocationUnit). self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: chunk) + chunkBytes. ^chunk]. freeListsMask := freeListsMask - (1 << index)]]. "now get desperate and use the first that'll fit. Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence start at initialIndex + 2." index := initialIndex + 1. [(index := index + 1) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(chunk := freeLists at: index) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assert: (self isValidFreeObject: chunk). self unlinkFreeChunk: chunk atIndex: index. self assert: (self bytesInObject: chunk) = (index * self allocationUnit). self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: chunk) + chunkBytes. ^chunk]. freeListsMask := freeListsMask - (1 << index)]]]. "Large chunk, or no space on small free lists. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the smallest chunk at least as large as chunkBytes, or 0 if none." parent := 0. child := freeLists at: 0. [child ~= 0] whileTrue: [| childBytes | self assert: (self isValidFreeObject: child). childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. chunk ~= 0 ifTrue: [self assert: (self isValidFreeObject: chunk). + self + setNextFreeChunkOf: child + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk) + sizeIsOne: false. - self storePointer: self freeChunkNextIndex - ofFreeChunk: child - withValue: (self fetchPointer: self freeChunkNextIndex - ofFreeChunk: chunk). ^self startOfObject: chunk]. nodeBytes := childBytes. parent := child. child := 0] "break out of loop to remove interior node" ifFalse: ["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger." childBytes <= (chunkBytes + self allocationUnit) ifTrue: "node too small; walk down the larger size of the tree" [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child] ifFalse: [parent := child. "parent will be smallest node >= chunkBytes + allocationUnit" nodeBytes := childBytes. child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]]. parent = 0 ifTrue: [totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded" ^nil]. "self printFreeChunk: parent" self assert: (nodeBytes = chunkBytes or: [nodeBytes >= (chunkBytes + (2 * self allocationUnit))]). self assert: (self bytesInObject: parent) = nodeBytes. "attempt to remove from list" chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: parent. chunk ~= 0 ifTrue: [self assert: (chunkBytes = nodeBytes or: [chunkBytes + self allocationUnit < nodeBytes]). + self + setNextFreeChunkOf: parent + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk) + sizeIsOne: false. - self storePointer: self freeChunkNextIndex - ofFreeChunk: parent - withValue: (self fetchPointer: self freeChunkNextIndex - ofFreeChunk: chunk). chunkBytes ~= nodeBytes ifTrue: [self freeChunkWithBytes: nodeBytes - chunkBytes at: (self startOfObject: chunk) + chunkBytes]. ^self startOfObject: chunk]. "no list; remove the interior node" chunk := parent. self unlinkSolitaryFreeTreeNode: chunk. "if there's space left over, add the fragment back." chunkBytes ~= nodeBytes ifTrue: [self freeChunkWithBytes: nodeBytes - chunkBytes at: (self startOfObject: chunk) + chunkBytes]. ^self startOfObject: chunk! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfBytes:suchThat: (in category 'free space') ----- allocateOldSpaceChunkOfBytes: chunkBytes suchThat: acceptanceBlock "Answer a chunk of oldSpace from the free lists that satisfies acceptanceBlock, if available, otherwise answer nil. Break up a larger chunk if one of the exact size cannot be found. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | initialIndex node next prev index child childBytes acceptedChunk acceptedNode | <inline: true> "must inline for acceptanceBlock" "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)" initialIndex := chunkBytes / self allocationUnit. (initialIndex < self numFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue: [(freeListsMask anyMask: 1 << initialIndex) ifTrue: [(node := freeLists at: initialIndex) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << initialIndex)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [freeLists at: initialIndex put: next] + ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. - ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next]. ^node]. prev := node. node := next]]]. "first search for free chunks of a multiple of chunkBytes in size" index := initialIndex. [(index := index + initialIndex) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << index)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [freeLists at: index put: next] + ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. - ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next]. self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: node) + chunkBytes. ^node]. prev := node. node := next]]]]. "now get desperate and use the first that'll fit. Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence start at initialIndex + 2." index := initialIndex + 1. [(index := index + 1) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << index)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [freeLists at: index put: next] + ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. - ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next]. self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: node) + chunkBytes. ^node]. prev := node. node := next]]]]]. "Large chunk, or no space on small free lists. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the smallest chunk at least as large as chunkBytes, or 0 if none. acceptedChunk and acceptedNode save us from having to back-up when the acceptanceBlock filters-out all nodes of the right size, but there are nodes of the wrong size it does accept." child := freeLists at: 0. node := acceptedChunk := acceptedNode := 0. [child ~= 0] whileTrue: [self assert: (self isValidFreeObject: child). childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [node := child. [prev := node. node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. node ~= 0] whileTrue: [(acceptanceBlock value: node) ifTrue: [self assert: (self isValidFreeObject: node). + self setNextFreeChunkOf: prev withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) sizeIsOne: false. - self storePointer: self freeChunkNextIndex - ofFreeChunk: prev - withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node). ^self startOfObject: node]]. (acceptanceBlock value: child) ifTrue: [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: child] ifFalse: "list; replace node with it" [self inFreeTreeReplace: child with: next]. ^self startOfObject: child]]. child ~= 0 ifTrue: ["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to leave room for the forwarding pointer/next free link, we can only break chunks that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger." childBytes <= (chunkBytes + self allocationUnit) ifTrue: "node too small; walk down the larger size of the tree" [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child] ifFalse: [self flag: 'we can do better here; preferentially choosing the lowest node. That would be a form of best-fit since we are trying to compact down'. node := child. child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node. acceptedNode = 0 ifTrue: [acceptedChunk := node. "first search the list." [acceptedChunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk. (acceptedChunk ~= 0 and: [acceptanceBlock value: acceptedChunk]) ifTrue: [acceptedNode := node]. acceptedChunk ~= 0 and: [acceptedNode = 0]] whileTrue. "nothing on the list; will the node do? This prefers acceptable nodes higher up the tree over acceptable list elements further down, but we haven't got all day..." (acceptedNode = 0 and: [acceptanceBlock value: node]) ifTrue: [acceptedNode := node. child := 0 "break out of loop now we have an acceptedNode"]]]]]. acceptedNode ~= 0 ifTrue: [acceptedChunk ~= 0 ifTrue: [self assert: (self bytesInObject: acceptedChunk) >= (chunkBytes + self allocationUnit). [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode. next ~= acceptedChunk] whileTrue: [acceptedNode := next]. + self + setNextFreeChunkOf: acceptedNode + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk) + sizeIsOne: false. - self storePointer: self freeChunkNextIndex - ofFreeChunk: acceptedNode - withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk). self freeChunkWithBytes: (self bytesInObject: acceptedChunk) - chunkBytes at: (self startOfObject: acceptedChunk) + chunkBytes. ^self startOfObject: acceptedChunk]. next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: acceptedNode] ifFalse: "list; replace node with it" [self inFreeTreeReplace: acceptedNode with: next]. self assert: (self bytesInObject: acceptedNode) >= (chunkBytes + self allocationUnit). self freeChunkWithBytes: (self bytesInObject: acceptedNode) - chunkBytes at: (self startOfObject: acceptedNode) + chunkBytes. ^self startOfObject: acceptedNode]. totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded" ^nil! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes: (in category 'free space') ----- allocateOldSpaceChunkOfExactlyBytes: chunkBytes "Answer a chunk of oldSpace from the free lists, if one of this size is available, otherwise answer nil. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | index node child | "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) ~= 0 ifTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self unlinkFreeChunk: node atIndex: index]. freeListsMask := freeListsMask - (1 << index)]. ^nil]. "Large chunk. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the first chunk of the same size as chunkBytes, or 0 if none." child := freeLists at: 0. [child ~= 0] whileTrue: [| childBytes | self assert: (self isValidFreeObject: child). childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. node ~= 0 ifTrue: [self assert: (self isValidFreeObject: node). + self + setNextFreeChunkOf: child + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) + sizeIsOne: false. - self storePointer: self freeChunkNextIndex - ofFreeChunk: child - withValue: (self fetchPointer: self freeChunkNextIndex - ofFreeChunk: node). totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: node]. "nothing acceptable on node's list; answer the node." self unlinkSolitaryFreeTreeNode: child. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: child] ifFalse: [child := self fetchPointer: (childBytes < chunkBytes ifTrue: [self freeChunkLargerIndex] ifFalse: [self freeChunkSmallerIndex]) ofFreeChunk: child]]. ^nil! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes:suchThat: (in category 'free space') ----- allocateOldSpaceChunkOfExactlyBytes: chunkBytes suchThat: acceptanceBlock "Answer a chunk of oldSpace from the free lists that satisfies acceptanceBlock, if one of this size is available, otherwise answer nil. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | index node next prev child childBytes | <inline: true> "must inline for acceptanceBlock" "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << index)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [freeLists at: index put: next] + ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. - ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next]. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^node]. prev := node. node := next]]]. ^nil]. "Large chunk. Search the large chunk list. Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks. When the search ends parent should hold the first chunk of the same size as chunkBytes, or 0 if none." node := 0. child := freeLists at: 0. [child ~= 0] whileTrue: [self "Sorry stepping over isValidFreeObject all the time was killing me" cCode: [self assert: (self isValidFreeObject: child)] inSmalltalk: [self assertValidFreeObject: child]. childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node first." [node := child. [prev := node. node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. node ~= 0] whileTrue: [(acceptanceBlock value: node) ifTrue: [self assert: (self isValidFreeObject: node). + self + setNextFreeChunkOf: prev + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) + sizeIsOne: false. - self storePointer: self freeChunkNextIndex - ofFreeChunk: prev - withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node). totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: node]]. (acceptanceBlock value: child) ifFalse: [^nil]. "node was right size but unaceptable." next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: child] ifFalse: "list; replace node with it" [self inFreeTreeReplace: child with: next]. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: child] ifFalse: "no size match; walk down the tree" [child := self fetchPointer: (childBytes < chunkBytes ifTrue: [self freeChunkLargerIndex] ifFalse: [self freeChunkSmallerIndex]) ofFreeChunk: child]]. ^nil! Item was changed: ----- Method: SpurMemoryManager>>assertValidFreeObject: (in category 'free space') ----- assertValidFreeObject: objOop <doNotGenerate> "If you want to generate this you want to use 'self assert: (self isValidFreeObject: objOop)' instead not to generate code in assertion-free VMs" | chunk | "duplicated assertions from isValidFreeObject: because I need to know what is wrong not only that it is not valid (I got bored of stepping inside isValidFreeObject:...)" self assert: (self oop: (self addressAfter: objOop) isLessThanOrEqualTo: endOfMemory). chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [self isFreeOop: chunk]). + (self bytesInObject: objOop) / self wordSize = 1 ifFalse: + ["double linkedlist assertions" + chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop. + chunk = 0 ifFalse: + [self assert: (self isFreeOop: chunk). + self assert: objOop = (self fetchPointer: self freeChunkPrevIndex ofFreeChunk: chunk)]. + chunk := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: objOop. + chunk = 0 ifFalse: + [self assert: (self isFreeOop: chunk). + self assert: objOop = (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk)].]. + (self isLargeFreeObject: objOop) ifTrue: + ["Tree assertions" - (self isLargeFreeObject: objOop) ifTrue: [ - "Tree assertions" chunk := self fetchPointer: self freeChunkParentIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). chunk := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). chunk := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). ]! Item was changed: ----- Method: SpurMemoryManager>>checkHeapFreeSpaceIntegrity (in category 'debug support') ----- checkHeapFreeSpaceIntegrity "Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccessibleFreeSpace has set a bit at each free chunk's header. Scan all objects in the heap checking that no pointer points to a free chunk and that all free chunks that refer to others refer to marked chunks. Answer if all checks pass." | ok total | <inline: false> <var: 'total' type: #usqInt> ok := true. total := 0. 0 to: self numFreeLists - 1 do: [:i| (freeLists at: i) ~= 0 ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) = 0 ifTrue: [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); cr. self eek. ok := false]]]. "Excuse the duplication but performance is at a premium and we avoid some tests by splitting the newSpace and oldSpace enumerations." self allNewSpaceEntitiesDo: [:obj| | fieldOop | (self isFreeObject: obj) ifTrue: [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; cr. self eek. ok := false] ifFalse: [0 to: (self numPointerSlotsOf: obj) - 1 do: [:fi| fieldOop := self fetchPointer: fi ofObject: obj. (self isNonImmediate: fieldOop) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; cr. self eek. ok := false]]]]]. self allOldSpaceEntitiesDo: [:obj| | fieldOop | (self isFreeObject: obj) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is unmapped?!! '; cr. self eek. ok := false]. fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr. self eek. ok := false]. + (self bytesInObject: obj) / self wordSize = 1 ifFalse: + [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj. + (fieldOop ~= 0 + and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: + [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr. + self eek. + ok := false]]. (self isLargeFreeObject: obj) ifTrue: [self freeChunkParentIndex to: self freeChunkLargerIndex do: [:fi| fieldOop := self fetchPointer: fi ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is unmapped'; cr. self eek. ok := false]]]. total := total + (self bytesInObject: obj)] ifFalse: [0 to: (self numPointerSlotsOf: obj) - 1 do: [:fi| (self isForwarded: obj) ifTrue: [self assert: fi = 0. "I'm now trying to use forwarders in GC algorithms..." fieldOop := self fetchPointer: fi ofMaybeForwardedObject: obj] ifFalse: "We keep #fetchPointer:ofObject: API here for assertions" [fieldOop := self fetchPointer: fi ofObject: obj]. (self isNonImmediate: fieldOop) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; cr. self eek. ok := false]]]]]. total ~= totalFreeOldSpace ifTrue: [coInterpreter print: 'incorrect totalFreeOldSpace; expected '; printNum: totalFreeOldSpace; print: ' found '; printNum: total; cr. self eek. ok := false]. ^ok! Item was changed: ----- Method: SpurMemoryManager>>checkHeapIntegrity:classIndicesShouldBeValid: (in category 'debug support') ----- checkHeapIntegrity: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid "Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccessibleObjects has set a bit at each (non-free) object's header. Scan all objects in the heap checking that every pointer points to a header. Scan the rememberedSet, remapBuffer and extraRootTable checking that every entry is a pointer to a header. Check that the number of roots is correct and that all rememberedSet entries have their isRemembered: flag set. Answer if all checks pass." | ok numRememberedObjectsInHeap | <inline: false> self cCode: [] inSmalltalk: ["Almost all of the time spent here used to go into the asserts in fetchPointer:ofObject: in the simulator class overrides. Since we know here the indices used are valid we temporarily remove them to claw back that performance." (self class whichClassIncludesSelector: #fetchPointer:ofObject:) ~= SpurMemoryManager ifTrue: [^self withSimulatorFetchPointerMovedAsideDo: [self checkHeapIntegrity: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid]]]. ok := true. numRememberedObjectsInHeap := 0. 0 to: self numFreeLists - 1 do: [:i| (freeLists at: i) ~= 0 ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) ~= 0 ifTrue: [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); cr. self eek. ok := false]]]. "Excuse the duplication but performance is at a premium and we avoid some tests by splitting the newSpace and oldSpace enumerations." self allNewSpaceEntitiesDo: [:obj| | fieldOop classIndex classOop | (self isFreeObject: obj) ifTrue: [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; cr. self eek. ok := false] ifFalse: [((self isMarked: obj) not and: [excludeUnmarkedObjs]) ifFalse: [(self isRemembered: obj) ifTrue: [coInterpreter print: 'young object '; printHex: obj; print: ' is remembered'; cr. self eek. ok := false]]. (self isForwarded: obj) ifTrue: [fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj. (heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue: [coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr. self eek. ok := false]] ifFalse: [classOop := self classOrNilAtIndex: (classIndex := self classIndexOf: obj). (classIndicesShouldBeValid and: [classOop = nilObj and: [(self isHiddenObj: obj) not]]) ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr. self eek. ok := false]. 0 to: (self numPointerSlotsOf: obj) - 1 do: [:fi| fieldOop := self fetchPointer: fi ofObject: obj. (self isNonImmediate: fieldOop) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr. self eek. ok := false]]]]]]. self allOldSpaceEntitiesDo: [:obj| | containsYoung fieldOop classIndex classOop | (self isFreeObject: obj) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0 ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is mapped?!! '; cr. self eek. ok := false]. fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is mapped'; cr. self eek. ok := false]. + (self bytesInObject: obj) / self wordSize = 1 ifFalse: + [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj. + (fieldOop ~= 0 + and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: + [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr. + self eek. + ok := false]]. (self isLargeFreeObject: obj) ifTrue: [self freeChunkParentIndex to: self freeChunkLargerIndex do: [:fi| fieldOop := self fetchPointer: fi ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is mapped'; cr. self eek. ok := false].]]] ifFalse: [(excludeUnmarkedObjs and: [(self isMarked: obj)not]) ifTrue: [] ifFalse: [ containsYoung := false. (self isRemembered: obj) ifTrue: [numRememberedObjectsInHeap := numRememberedObjectsInHeap + 1. (scavenger isInRememberedSet: obj) ifFalse: [coInterpreter print: 'remembered object '; printHex: obj; print: ' is not in remembered table'; cr. self eek. ok := false]]. (self isForwarded: obj) ifTrue: [fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj. (heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue: [coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr. self eek. ok := false]. (self isReallyYoung: fieldOop) ifTrue: [containsYoung := true]] ifFalse: [classOop := self classOrNilAtIndex: (classIndex := self classIndexOf: obj). (classIndicesShouldBeValid and: [classOop = nilObj and: [classIndex > self lastClassIndexPun]]) ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr. self eek. ok := false]. 0 to: (self numPointerSlotsOf: obj) - 1 do: [:fi| fieldOop := self fetchPointer: fi ofObject: obj. (self isNonImmediate: fieldOop) ifTrue: [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr. self eek. ok := false]. "don't be misled by CogMethods; they appear to be young, but they're not" (self isReallyYoung: fieldOop) ifTrue: [containsYoung := true]]]]. containsYoung ifTrue: [(self isRemembered: obj) ifFalse: [coInterpreter print: 'unremembered object '; printHex: obj; print: ' contains young oop(s)'; cr. self eek. ok := false]]]]]. numRememberedObjectsInHeap ~= scavenger rememberedSetSize ifTrue: [coInterpreter print: 'root count mismatch. #heap roots '; printNum: numRememberedObjectsInHeap; print: '; #roots '; printNum: scavenger rememberedSetSize; cr. self eek. "But the system copes with overflow..." self flag: 'no support for remembered set overflow yet'. "ok := rootTableOverflowed and: [needGCFlag]"]. scavenger rememberedSetWithIndexDo: [:obj :i| (obj bitAnd: self wordSize - 1) ~= 0 ifTrue: [coInterpreter print: 'misaligned oop in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr. self eek. ok := false] ifFalse: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'object leak in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr. self eek. ok := false] ifFalse: [(self isYoung: obj) ifTrue: [coInterpreter print: 'non-root in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr. self eek. ok := false]]]]. self objStack: mournQueue do: [:i :page| | obj | obj := self fetchPointer: i ofObject: page. (obj bitAnd: self wordSize - 1) ~= 0 ifTrue: [coInterpreter print: 'misaligned oop in mournQueue @ '; printNum: i; print: ' in '; printHex: page; print: ' = '; printHex: obj; cr. self eek. ok := false] ifFalse: [(excludeUnmarkedObjs and: [(self isMarked: obj) not]) ifFalse: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'object leak in mournQueue @ '; printNum: i; print: ' in '; printHex: page; print: ' = '; printHex: obj; cr. self eek. ok := false]]]]. 1 to: remapBufferCount do: [:ri| | obj | obj := remapBuffer at: ri. (obj bitAnd: self wordSize - 1) ~= 0 ifTrue: [coInterpreter print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr. self eek. ok := false] ifFalse: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr. self eek. ok := false]]]. 1 to: extraRootCount do: [:ri| | obj | obj := (extraRoots at: ri) at: 0. (obj bitAnd: self wordSize - 1) ~= 0 ifTrue: [coInterpreter print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr. self eek. ok := false] ifFalse: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr. self eek. ok := false]]]. ^ok! Item was changed: ----- Method: SpurMemoryManager>>detachFreeObject: (in category 'free space') ----- detachFreeObject: freeChunk "This is a rare operation, so its efficiency isn't critical. Having a valid prev link for tree nodes would help." + <inline: true> + | chunkBytes | - <inline: false> - | chunkBytes result | chunkBytes := self bytesInObject: freeChunk. + totalFreeOldSpace := totalFreeOldSpace - chunkBytes. + self unlinkFreeChunk: freeChunk chunkBytes: chunkBytes! - result := self allocateOldSpaceChunkOfExactlyBytes: chunkBytes suchThat: [:f| f = freeChunk]. - self assert: result = (self startOfObject: freeChunk). - ! Item was removed: - ----- Method: SpurMemoryManager>>freeChunkNextAddressIndex (in category 'free space') ----- - freeChunkNextAddressIndex - "for sorting free chunks in memory order" - ^1! Item was added: + ----- Method: SpurMemoryManager>>freeChunkPrevIndex (in category 'free space') ----- + freeChunkPrevIndex + "For linking objecs on each free list, doubly-linking the free objects. + Free chunks of size 1 do not have a prev index." + ^1! Item was added: + ----- Method: SpurMemoryManager>>freeTreeOverlapCheck (in category 'free space') ----- + freeTreeOverlapCheck + <doNotGenerate> + "Assumes no 2 consecutive free chunks" + self allObjectsInFreeTreeDo: [:freeNode1| + self allObjectsInFreeTreeDo: [:freeNode2| + freeNode1 == freeNode2 + ifFalse: + [|start1 start2 end1 end2| + start1 := self startOfObject: freeNode1. + start2 := self startOfObject: freeNode2. + end1 := start1 + (self bytesInObject: freeNode1). + end2 := start2 + (self bytesInObject: freeNode2). + " + Transcript + show: '['; show: start1; show: ';'; + show: end1; show: '];'; cr; show: '['; show: start2; + show: ';'; show: end2; show: ']'; cr. + " + self assert: (start2 > end1 or: [end2 < start1]). + self assert: (start1 > end2 or: [start1 < start2])]]].! Item was changed: ----- Method: SpurMemoryManager>>inFreeTreeReplace:with: (in category 'free space') ----- inFreeTreeReplace: treeNode with: newNode "Part of reorderReversedTreeList:. Switch treeNode with newNode in the tree, but do nothing to the list linked through freeChunkNextIndex." | relative | + self storePointer: self freeChunkPrevIndex ofFreeChunk: newNode withValue: 0. "copy parent, smaller, larger" self freeChunkParentIndex to: self freeChunkLargerIndex do: [:i| relative := self fetchPointer: i ofFreeChunk: treeNode. i = self freeChunkParentIndex ifTrue: [relative = 0 ifTrue: "update root to point to newNode" [self assert: (freeLists at: 0) = treeNode. freeLists at: 0 put: newNode] ifFalse: "replace link from parent to treeNode with link to newNode." [self storePointer: (treeNode = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: relative) ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: relative withValue: newNode]] ifFalse: [relative ~= 0 ifTrue: [self assert: (self fetchPointer: self freeChunkParentIndex ofFreeChunk: relative) = treeNode. self storePointer: self freeChunkParentIndex ofFreeChunk: relative withValue: newNode]]. self storePointer: i ofFreeChunk: newNode withValue: relative. self storePointer: i ofFreeChunk: treeNode withValue: 0]! Item was changed: ----- Method: SpurMemoryManager>>initializeObjectMemory: (in category 'initialization') ----- initializeObjectMemory: bytesToShift "Initialize object memory variables at startup time. Assume endOfMemory at al are initialised by the image-reading code via setHeapBase:memoryLimit:endOfMemory:. endOfMemory is assumed to point to the end of the last object in the image. Assume: image reader also initializes the following variables: specialObjectsOop lastHash" <inline: false> | freeListObj | "Catch mis-initializations leading to bad translations to C" self assert: self baseHeaderSize = self baseHeaderSize. self assert: (self maxSlotsForAlloc * self wordSize) asInteger > 0. self bootstrapping ifFalse: [self initSegmentBridgeWithBytes: self bridgeSize at: endOfMemory - self bridgeSize]. segmentManager adjustSegmentSwizzlesBy: bytesToShift. "image may be at a different address; adjust oops for new location" self adjustAllOopsBy: bytesToShift. specialObjectsOop := segmentManager swizzleObj: specialObjectsOop. "heavily used special objects" nilObj := self splObj: NilObject. falseObj := self splObj: FalseObject. trueObj := self splObj: TrueObject. "In Cog we insist that nil, true & false are next to each other (Cogit generates tighter conditional branch code as a result). In addition, Spur places the free lists and class table root page immediately following them." self assert: nilObj = oldSpaceStart. self assert: falseObj = (self oldSpaceObjectAfter: nilObj). self assert: trueObj = (self oldSpaceObjectAfter: falseObj). freeListObj := self oldSpaceObjectAfter: trueObj. self setHiddenRootsObj: (self oldSpaceObjectAfter: freeListObj). markStack := self swizzleObjStackAt: MarkStackRootIndex. weaklingStack := self swizzleObjStackAt: WeaklingStackRootIndex. mournQueue := self swizzleObjStackAt: MournQueueRootIndex. self assert: self validObjStacks. self assert: (self isEmptyObjStack: markStack). self assert: (self isEmptyObjStack: weaklingStack). self initializeFreeSpacePostLoad: freeListObj. segmentManager collapseSegmentsPostSwizzle. + self updateFreeLists. self computeFreeSpacePostSwizzle. compactor postSwizzleAction. self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart, free space" self initializeNewSpaceVariables. scavenger initializeRememberedSet. segmentManager checkSegments. compactor biasForGC. "These defaults should depend on machine size; e.g. too small on a powerful laptop, too big on a Pi." growHeadroom := 16*1024*1024. "headroom when growing" shrinkThreshold := 32*1024*1024. "free space before shrinking" self setHeapSizeAtPreviousGC. heapGrowthToSizeGCRatio := 0.333333. "By default GC after scavenge if heap has grown by a third since the last GC"! Item was changed: ----- Method: SpurMemoryManager>>isValidFreeObject: (in category 'free space') ----- isValidFreeObject: objOop | chunk | ^(self addressCouldBeOldObj: objOop) and: [(self isFreeObject: objOop) and: [(self oop: (self addressAfter: objOop) isLessThanOrEqualTo: endOfMemory) and: [((chunk := (self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop)) = 0 or: [self isFreeOop: chunk]) + and: [((chunk := (self fetchPointer: self freeChunkPrevIndex ofFreeChunk: objOop)) = 0 + or: [self isFreeOop: chunk]) and: [(self isLargeFreeObject: objOop) not or: [((chunk := (self fetchPointer: self freeChunkParentIndex ofFreeChunk: objOop)) = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]) and: [((chunk := (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: objOop)) = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]) and: [(chunk := (self fetchPointer: self freeChunkLargerIndex ofFreeChunk: objOop)) = 0 + or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]]]]]]]]]! - or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]]]]]]]]! Item was removed: - ----- Method: SpurMemoryManager>>rebuildFreeTreeFrom: (in category 'free space') ----- - rebuildFreeTreeFrom: sortedFreeChunks - "post sweep and pre compact, rebuild the large free chunk tree from the - sortedFreeChunks list, such that the lists are ordered from low to high address." - | freeChunk bytes totalBytes | - "first add all the chunks to the tree. This will result in almost address-sorted lists. - We will need to reorder the lists." - freeChunk := sortedFreeChunks. - totalBytes := 0. - [freeChunk ~= 0] whileTrue: - [bytes := self bytesInObject: freeChunk. - totalBytes := totalBytes + bytes. - self addToFreeTree: freeChunk bytes: bytes. - freeChunk := self fetchPointer: self freeChunkNextAddressIndex - ofFreeChunk: freeChunk]. - "now reorder the lists to ensure they're in address order, apart from the list head, which should be highest." - self freeTreeNodesDo: - [:treeNode| | newTreeNode | - newTreeNode := self reorderReversedTreeList: treeNode. - newTreeNode]. - ^totalBytes! Item was removed: - ----- Method: SpurMemoryManager>>reorderReversedTreeList: (in category 'free space') ----- - reorderReversedTreeList: treeNode - "Once the freeTree has been rebuilt from the sortedFreeChunks list - each list will be in a weird order, the list in reverse order, high to low, - but the tree node, because it is inserted first, will be the lowest address. - Reverse the list so it is sorted low to high, but make the highest address - node the first, as this will be allocated from last." - | first next node prev | - "first becomes the new head, as this is the last one we want to allocate and we allocate from the list first." - first := self fetchPointer: self freeChunkNextIndex ofFreeChunk: treeNode. - "no next node, so no change" - first = 0 ifTrue: - [^treeNode]. - node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: first. - self storePointer: self freeChunkNextIndex ofFreeChunk: first withValue: treeNode. - self inFreeTreeReplace: treeNode with: first. - prev := 0. - [node ~= 0] whileTrue: - [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. - self storePointer: self freeChunkNextIndex ofFreeChunk: node withValue: prev. - prev := node. - node := next]. - self storePointer: self freeChunkNextIndex ofFreeChunk: treeNode withValue: prev. - ^first! Item was removed: - ----- Method: SpurMemoryManager>>reverseSmallListHeads (in category 'free space') ----- - reverseSmallListHeads - "After freeUnmarkedObjectsNilUnmarkedWeaklingSlotsAndSortAndCoalesceFreeSpace - all small free chunks will be on the free lists in reverse address order. Reverse each list, - summing the ammount of space. Answer the sum of bytes of free space on these small lists." - | total | - total := 0. - freeListsMask := 0. - 1 to: self numFreeLists - 1 do: - [:i| | bytes node prev next | - bytes := i * self allocationUnit. - node := freeLists at: i. - node ~= 0 ifTrue: - [self assert: (self bytesInObject: node) = bytes. - freeListsMask := freeListsMask + (1 << i). - prev := 0. - [node ~= 0] whileTrue: - [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. - self storePointer: self freeChunkNextIndex ofFreeChunk: node withValue: prev. - prev := node. - node := next. - total := total + bytes]. - freeLists at: i put: prev]]. - ^total! Item was added: + ----- Method: SpurMemoryManager>>setNextFreeChunkOf:withValue:chunkBytes: (in category 'free space') ----- + setNextFreeChunkOf: freeChunk withValue: nextFreeChunk chunkBytes: chunkBytes + <inline: true> + self + setNextFreeChunkOf: freeChunk + withValue: nextFreeChunk + sizeIsOne: chunkBytes / self wordSize = 1 + + ! Item was added: + ----- Method: SpurMemoryManager>>setNextFreeChunkOf:withValue:sizeIsOne: (in category 'free space') ----- + setNextFreeChunkOf: freeChunk withValue: nextFreeChunk sizeIsOne: sizeIsOne + <inline: true> "Inlining is quite important since sizeIsOne is often false" + self + storePointer: self freeChunkNextIndex + ofFreeChunk: freeChunk + withValue: nextFreeChunk. + "In 32 bits, there's always enough room, + in 64 bits, size 1 is special." + (nextFreeChunk = 0 or: [sizeIsOne]) ifFalse: + [self + storePointer: self freeChunkPrevIndex + ofFreeChunk: nextFreeChunk + withValue: freeChunk] + + ! Item was removed: - ----- Method: SpurMemoryManager>>sortFreeListAt: (in category 'free space') ----- - sortFreeListAt: i - "Sort the individual free list i so that the lowest address is at the head of the list. - Use an insertion sort with a scan for initially sorted elements." - - | list next head | - list := freeLists at: i. "list of objects to be inserted" - list = 0 ifTrue: "empty list; we're done" - [^self]. - head := list. - "scan list to find find first out-of-order element" - [(next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: list) > list] - whileTrue: - [list := next]. - "no out-of-order elements; list was already sorted; we're done" - next = 0 ifTrue: - [^self]. - "detatch already sorted list" - self storePointer: self freeChunkNextIndex ofFreeChunk: list withValue: 0. - list := next. - [list ~= 0] whileTrue: - [| node prev | - "grab next node to be inserted" - next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: list. - "search sorted list for insertion point" - prev := 0. "prev node for insertion sort" - node := head. "current node for insertion sort" - [node ~= 0 - and: [self oop: node isLessThan: list]] whileTrue: - [prev := node. - node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node]. - "insert the node into the sorted list" - self assert: (node = 0 or: [node > list]). - prev = 0 - ifTrue: - [head := list] - ifFalse: - [self storePointer: self freeChunkNextIndex - ofFreeChunk: prev - withValue: list]. - self storePointer: self freeChunkNextIndex - ofFreeChunk: list - withValue: node. - list := next]. - "replace the list with the sorted list" - freeLists at: i put: head! Item was changed: ----- Method: SpurMemoryManager>>swizzleFieldsOfFreeChunk: (in category 'snapshot') ----- swizzleFieldsOfFreeChunk: chunk <inline: true> + | field chunkBytes | - | field | field := self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk. field ~= 0 ifTrue: [self storePointerNoAssert: self freeChunkNextIndex ofFreeChunk: chunk withValue: (segmentManager swizzleObj: field)]. + (chunkBytes := self bytesInObject: chunk) / self wordSize = 1 ifFalse: + [field := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: chunk. + field ~= 0 ifTrue: + [self storePointerNoAssert: self freeChunkPrevIndex + ofFreeChunk: chunk + withValue: (segmentManager swizzleObj: field)]]. + chunkBytes >= (self numFreeLists * self allocationUnit) ifTrue: - (self bytesInObject: chunk) >= (self numFreeLists * self allocationUnit) ifTrue: [self freeChunkParentIndex to: self freeChunkLargerIndex do: [:index| field := self fetchPointer: index ofFreeChunk: chunk. field ~= 0 ifTrue: [self storePointerNoAssert: index ofFreeChunk: chunk withValue: (segmentManager swizzleObj: field)]]]! Item was changed: ----- Method: SpurMemoryManager>>totalFreeListBytes (in category 'free space') ----- totalFreeListBytes "This method both computes the actual number of free bytes by traversing all free objects on the free lists/tree, and checks that the tree is valid. It is used mainly by checkFreeSpace." | totalFreeBytes bytesInChunk listNode nextNode | totalFreeBytes := 0. 1 to: self numFreeLists - 1 do: [:i| bytesInChunk := i * self allocationUnit. listNode := freeLists at: i. [listNode ~= 0] whileTrue: [totalFreeBytes := totalFreeBytes + bytesInChunk. + self + cCode: [self assert: (self isValidFreeObject: listNode)] + inSmalltalk: [self assertValidFreeObject: listNode]. - self assert: (self isValidFreeObject: listNode). self assert: bytesInChunk = (self bytesInObject: listNode). nextNode := self fetchPointer: self freeChunkNextIndex ofFreeChunk: listNode. self assert: nextNode ~= listNode. listNode := nextNode]]. self freeTreeNodesDo: [:treeNode| bytesInChunk := self bytesInObject: treeNode. self assert: bytesInChunk / self allocationUnit >= self numFreeLists. listNode := treeNode. [listNode ~= 0] whileTrue: ["self printFreeChunk: listNode" self assert: (self isValidFreeObject: listNode). self assert: (listNode = treeNode or: [(self fetchPointer: self freeChunkParentIndex ofFreeChunk: listNode) = 0]). totalFreeBytes := totalFreeBytes + bytesInChunk. self assert: bytesInChunk = (self bytesInObject: listNode). nextNode := self fetchPointer: self freeChunkNextIndex ofFreeChunk: listNode. self assert: nextNode ~= listNode. listNode := nextNode]. treeNode]. ^totalFreeBytes! Item was removed: - ----- Method: SpurMemoryManager>>unlinkFreeChunk: (in category 'free space') ----- - unlinkFreeChunk: freeChunk - "Unlink a free object from the free lists. Do not alter totalFreeOldSpace. Used for coalescing." - | chunkBytes index node next prev child childBytes | - index := (chunkBytes := self bytesInObject: freeChunk) / self allocationUnit. - (index < self numFreeLists and: [1 << index <= freeListsMask]) ifTrue: - [self assert: ((freeListsMask anyMask: 1 << index) and: [(freeLists at: index) ~= 0]). - node := freeLists at: index. - prev := 0. - [node ~= 0] whileTrue: - [self assert: node = (self startOfObject: node). - self assert: (self isValidFreeObject: node). - next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. - node = freeChunk ifTrue: - [prev = 0 - ifTrue: [freeLists at: index put: next] - ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next]. - ^self]. - prev := node. - node := next]. - self error: 'freeChunk not found in free lists']. - - "Large chunk. Search the large chunk tree." - child := freeLists at: 0. - node := 0. - [child ~= 0] whileTrue: - [self assert: (self isValidFreeObject: child). - childBytes := self bytesInObject: child. - childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." - [node := child. - [prev := node. - node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. - node ~= 0] whileTrue: - [node = freeChunk ifTrue: - [self assert: (self isValidFreeObject: node). - self storePointer: self freeChunkNextIndex - ofFreeChunk: prev - withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node). - ^self]]. - child = freeChunk ifTrue: - [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. - next = 0 - ifTrue: "no list; remove the interior node" - [self unlinkSolitaryFreeTreeNode: child] - ifFalse: "list; replace node with it" - [self inFreeTreeReplace: child with: next]. - ^self]]. - child ~= 0 ifTrue: - [childBytes < chunkBytes - ifTrue: "node too small; walk down the larger size of the tree" - [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child] - ifFalse: - [node := child. - child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node]]]. - - self error: 'freeChunk not found in free tree' - ! Item was changed: ----- Method: SpurMemoryManager>>unlinkFreeChunk:atIndex: (in category 'free space') ----- unlinkFreeChunk: chunk atIndex: index "Unlink and answer a small chunk from one of the fixed size freeLists" <inline: true> + |next| self assert: ((self bytesInObject: chunk) = (index * self allocationUnit) and: [index > 1 "a.k.a. (self bytesInObject: chunk) > self allocationUnit" and: [(self startOfObject: chunk) = chunk]]). freeLists at: index + put: (next := self - put: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk). + next = 0 ifFalse: [self storePointer: self freeChunkPrevIndex ofFreeChunk: next withValue: 0]. ^chunk! Item was added: + ----- Method: SpurMemoryManager>>unlinkFreeChunk:chunkBytes: (in category 'free space') ----- + unlinkFreeChunk: freeChunk chunkBytes: chunkBytes + "Unlink a free object from the free lists. Do not alter totalFreeOldSpace. Used for coalescing." + | index node next prev | + index := chunkBytes / self allocationUnit. + + "Pathological 64 bits case - size 1 - single linked list" + chunkBytes / self wordSize = 1 ifTrue: + [node := freeLists at: index. + prev := 0. + [node ~= 0] whileTrue: + [self assert: node = (self startOfObject: node). + self assert: (self isValidFreeObject: node). + next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. + node = freeChunk ifTrue: + [prev = 0 + ifTrue: [freeLists at: index put: next] + ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. + ^self]. + prev := node. + node := next]. + self error: 'freeChunk not found in free list of size 1']. + + prev := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: freeChunk. + "Has prev element: update double linked list" + prev ~= 0 ifTrue: + [self + setNextFreeChunkOf: prev + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk) + chunkBytes: chunkBytes. + ^self]. + + "Is the beginning of a list" + "Small chunk" + (index < self numFreeLists and: [1 << index <= freeListsMask]) ifTrue: [ + ^self unlinkFreeChunk: freeChunk atIndex: index]. + "Large chunk" + next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk. + next = 0 + ifTrue: "no list; remove the interior node" + [self unlinkSolitaryFreeTreeNode: freeChunk] + ifFalse: "list; replace node with it" + [self inFreeTreeReplace: freeChunk with: next] + + + + ! Item was removed: - ----- Method: SpurMemoryManager>>unlinkFreeTreeNode:withSiblings: (in category 'free space') ----- - unlinkFreeTreeNode: freeTreeNode withSiblings: next - "Unlink a freeTreeNode. Assumes the node has a list (non-null next link)." - | parent smaller larger | - parent := self fetchPointer: self freeChunkParentIndex ofObject: freeTreeNode. - smaller := self fetchPointer: self freeChunkSmallerIndex ofObject: freeTreeNode. - larger := self fetchPointer: self freeChunkLargerIndex ofObject: freeTreeNode. - parent = 0 - ifTrue: [freeLists at: 0 put: next] - ifFalse: - [self storePointer: (freeTreeNode = (self fetchPointer: self freeChunkSmallerIndex - ofObject: parent) - ifTrue: [self freeChunkSmallerIndex] - ifFalse: [self freeChunkLargerIndex]) - ofFreeChunk: parent - withValue: next. - self storePointer: self freeChunkParentIndex ofFreeChunk: next withValue: parent]. - self storePointer: self freeChunkSmallerIndex ofFreeChunk: next withValue: smaller. - smaller ~= 0 ifTrue: - [self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: next]. - self storePointer: self freeChunkLargerIndex ofFreeChunk: next withValue: larger. - larger ~= 0 ifTrue: - [self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: next]! Item was added: + ----- Method: SpurMemoryManager>>updateFreeLists (in category 'initialization') ----- + updateFreeLists + "Snapshot did not guarantee the state of the freelist prevLink, so we need to update it. + Effectively transforms the freechunk single linked list in double linked list." + |min| + "Small chunks" + "Skip in 64 bits size 1 which is single linked list - pathological case" + self allocationUnit / self wordSize = 1 ifTrue: [min := 2] ifFalse: [min := 1]. + min to: self numFreeLists - 1 do: + [:i| self updateListStartingAt: (freeLists at: i)]. + "Large chunks" + self freeTreeNodesDo: [:freeNode | + self updateListStartingAt: freeNode. + freeNode]! Item was added: + ----- Method: SpurMemoryManager>>updateListStartingAt: (in category 'initialization') ----- + updateListStartingAt: freeNode + |prev obj| + prev := freeNode. + self storePointer: self freeChunkPrevIndex ofFreeChunk: prev withValue: 0. + [obj := self fetchPointer: self freeChunkNextIndex ofFreeChunk: prev. + obj ~= 0] whileTrue: + [self storePointer: self freeChunkPrevIndex ofFreeChunk: obj withValue: prev. + prev := obj]! Item was removed: - SpurCompactor subclass: #SpurPigCompactor - instanceVariableNames: 'firstFreeChunk lastFreeChunk numCompactionPasses' - classVariableNames: 'CompactionPassesForGC CompactionPassesForSnapshot' - poolDictionaries: '' - category: 'VMMaker-SpurMemoryManager'! - - !SpurPigCompactor commentStamp: 'eem 12/16/2016 16:20' prior: 0! - SpurPigCompactor implements the second compactioon algorithm implemented for Spur. It attempts to move ovbjects down from the end of memory to occupy free chunks in low memory. It uses Knuth's xor-encoding technique to encode a doubly-linked list in the forwarding field of each free chunk (free chunks, like Spiur objects, being known to have at least one field). This algorithm has poor performance for two reasons. First, it does not preserve object order, scrambling the order of objects as it moves the highest objects down to the lowest free chunks. Second it appears to perform badly, occasionally causing very long pauses. - - Instance Variables - coInterpreter: <StackInterpreter> - firstFreeChunk: <Integer> - lastFreeChunk: <Integer> - manager: <SpurMemoryManager> - numCompactionPasses: <Integer> - scavenger: <SpurGenerationScavenger> - - firstFreeChunk - - oop of freeChunk or 0 - - lastFreeChunk - - oop of freeChunk or 0 - - numCompactionPasses - - 2 for normal GC, 3 for snapshot! Item was removed: - ----- Method: SpurPigCompactor class>>initialize (in category 'class initialization') ----- - initialize - "Pig compact can be repeated to compact better. Experience shows that 3 times - compacts very well, desirable for snapshots. But this is overkill for normal GCs." - CompactionPassesForGC := 2. - CompactionPassesForSnapshot := 3! Item was removed: - ----- Method: SpurPigCompactor>>abstractPigCompaction (in category 'compaction - analysis') ----- - abstractPigCompaction - "This method answers a rough estimate of compactibility using a pig (a large free chunk)." - <doNotGenerate> - | pig pork moved unmoved nmoved nunmoved | - pig := self findAPig. - pork := manager bytesInObject: pig. - moved := unmoved := nmoved := nunmoved := 0. - manager allOldSpaceObjectsFrom: pig do: - [:o| | bytes | - bytes := manager bytesInObject: o. - bytes <= pork - ifTrue: - [moved := moved + bytes. - nmoved := nmoved + 1. - pork := pork - bytes] - ifFalse: - [unmoved := unmoved + bytes. - nunmoved := nunmoved + 1]]. - ^{ manager bytesInObject: pig. pork. moved. nmoved. unmoved. nunmoved }! Item was removed: - ----- Method: SpurPigCompactor>>biasForGC (in category 'compaction - api') ----- - biasForGC - numCompactionPasses := CompactionPassesForGC! Item was removed: - ----- Method: SpurPigCompactor>>biasForSnapshot (in category 'compaction - api') ----- - biasForSnapshot - numCompactionPasses := CompactionPassesForSnapshot! Item was removed: - ----- Method: SpurPigCompactor>>checkNoForwardersBelowFirstFreeChunk (in category 'compaction - asserts') ----- - checkNoForwardersBelowFirstFreeChunk - manager allOldSpaceEntitiesDo: - [:o| - (self oop: o isGreaterThanOrEqualTo: firstFreeChunk) ifTrue: - [^true]. - (self asserta: (manager isForwarded: o) not) ifFalse: - [^false]]. - ^true! Item was removed: - ----- Method: SpurPigCompactor>>checkTraversableSortedFreeList (in category 'compaction - asserts') ----- - checkTraversableSortedFreeList - | prevFree prevPrevFree freeChunk | - <api> - <inline: false> - prevFree := prevPrevFree := 0. - firstFreeChunk = 0 ifTrue: - [^lastFreeChunk = 0]. - freeChunk := firstFreeChunk. - manager allOldSpaceEntitiesDo: - [:o| | objOop next limit | - (manager isFreeObject: o) ifTrue: - [self assert: o = freeChunk. - next := self nextInSortedFreeListLink: freeChunk given: prevFree. - limit := next = 0 ifTrue: [manager endOfMemory] ifFalse: [next]. - "coInterpreter transcript cr; print: freeChunk; tab; print: o; tab; print: prevFree; nextPutAll: '<->'; print: next; flush." - objOop := freeChunk. - [self oop: (objOop := manager objectAfter: objOop) isLessThan: limit] whileTrue: - [self assert: (manager isFreeObject: objOop) not]. - prevPrevFree := prevFree. - prevFree := freeChunk. - freeChunk := next]]. - self assert: prevFree = lastFreeChunk. - self assert: (self nextInSortedFreeListLink: lastFreeChunk given: 0) = prevPrevFree. - self assert: freeChunk = 0. - ^true! Item was removed: - ----- Method: SpurPigCompactor>>compact (in category 'compaction - api') ----- - compact - "We'd like to use exact fit followed by best or first fit, but it doesn't work - well enough in practice. So use pig compact. Fill large free objects starting - from low memory with objects taken from the end of memory." - <inline: #never> "for profiling" - self freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact. - manager statCompactPassCount: manager statCompactPassCount + 1. - self assert: (firstFreeChunk = 0 or: [manager isFreeObject: firstFreeChunk]). - 1 to: numCompactionPasses do: - [:i| - self pigCompact. - self eliminateAndFreeForwardersForPigCompact]. - - "The free lists are zeroed in freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact. - They should still be zero here" - self assert: manager freeListHeadsEmpty. - self rebuildFreeListsForPigCompact! Item was removed: - ----- Method: SpurPigCompactor>>eliminateAndFreeForwardersForPigCompact (in category 'compaction') ----- - eliminateAndFreeForwardersForPigCompact - "As the final phase of global garbage collect, sweep the heap to follow - forwarders, then free forwarders, coalescing with free space as we go." - <inline: false> - | lowestForwarder | - <var: #lowestForwarder type: #usqInt> - self assert: (manager isForwarded: manager nilObject) not. - self assert: (manager isForwarded: manager falseObject) not. - self assert: (manager isForwarded: manager trueObject) not. - self assert: (manager isForwarded: manager freeListsObj) not. - self assert: (manager isForwarded: manager hiddenRootsObject) not. - self assert: (manager isForwarded: manager classTableFirstPage) not. - manager followSpecialObjectsOop. - manager followForwardedObjStacks. - coInterpreter mapInterpreterOops. - scavenger followRememberedForwardersAndForgetFreeObjectsForPigCompact. - manager unmarkSurvivingObjectsForCompact. - lowestForwarder := self sweepToFollowForwardersForPigCompact. - self sweepToCoallesceFreeSpaceForPigCompactFrom: lowestForwarder. - self assert: manager numberOfForwarders = 0! Item was removed: - ----- Method: SpurPigCompactor>>findAPig (in category 'compaction - analysis') ----- - findAPig - "Answer a large low free chunk." - <doNotGenerate> - | pig | - manager allObjectsInFreeTreeDo: - [:f| - (manager bytesInObject: f) >= 1000000 ifTrue: - [(pig isNil or: [pig > f]) ifTrue: - [pig := f]]]. - ^pig! Item was removed: - ----- Method: SpurPigCompactor>>freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact (in category 'compaction') ----- - freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact - "Sweep all of old space, freeing unmarked objects, coalescing free chunks, and sorting free space. - - Doubly-link the free chunks in address order through the freeChunkNextIndex field using the - xor trick to use only one field, see e.g. - The Art of Computer Programming, Vol 1, D.E. Knuth, 3rd Ed, Sec 2.2.4 `Circular Lists', exercise. 18 - http://en.wikipedia.org/wiki/XOR_linked_list. - Record the lowest free object in firstFreeChunk and the highest in lastFreeChunk. - - Let the segmentManager mark which segments contain pinned objects via notePinned:." - - | prevPrevFree prevFree | - <inline: #never> "for profiling" - manager checkFreeSpace: GCModeFull. - "throw away the list heads, including the tree." - manager resetFreeListHeads. - firstFreeChunk := prevPrevFree := prevFree := 0. - manager allOldSpaceEntitiesForCoalescingFrom: manager firstObject do: - [:o| - self assert: (firstFreeChunk = 0 or: [manager isFreeObject: firstFreeChunk]). - (manager isMarked: o) - ifTrue: "forwarders should have been followed in markAndTrace:" - [self assert: (manager isForwarded: o) not. - manager setIsMarkedOf: o to: false. "this will unmark bridges. undo the damage in notePinned:" - (manager isPinned: o) ifTrue: - [manager segmentManager notePinned: o]] - ifFalse: "unmarked; two cases, an unreachable object or a free chunk." - [| here | - self assert: (manager isRemembered: o) not. "scavenger should have cleared this above" - here := manager coallesceFreeChunk: o. - manager setObjectFree: here. - self inSortedFreeListLink: prevFree to: here given: prevPrevFree. - prevPrevFree := prevFree. - prevFree := here]]. - prevFree ~= firstFreeChunk ifTrue: - [manager storePointer: manager freeChunkNextIndex - ofFreeChunk: prevFree - withValue: prevPrevFree]. - lastFreeChunk := prevFree. - self inSortedFreeListLink: lastFreeChunk to: 0 given: prevPrevFree. - self assert: self checkTraversableSortedFreeList! Item was removed: - ----- Method: SpurPigCompactor>>inSortedFreeListLink:to:given: (in category 'compaction') ----- - inSortedFreeListLink: freeChunk to: nextFree given: prevFree - "Doubly-link the free chunk in address order through the freeChunkNextIndex field using the - xor trick to use only one field, see e.g. - The Art of Computer Programming, Vol 1, D.E. Knuth, 3rd Ed, Sec 2.2.4 `Circular Lists', exercise. 18 - http://en.wikipedia.org/wiki/XOR_linked_list." - freeChunk = 0 - ifTrue: - [firstFreeChunk := nextFree] - ifFalse: - [manager storePointer: manager freeChunkNextIndex - ofFreeChunk: freeChunk - withUncheckedValue: (prevFree bitXor: nextFree)]! Item was removed: - ----- Method: SpurPigCompactor>>moveARunOfObjectsStartingAt:upTo: (in category 'compaction') ----- - moveARunOfObjectsStartingAt: startAddress upTo: limit - "Move the sequence of movable objects starting at startAddress. Answer the start - of the next sequence of movable objects after a possible run of unmovable objects, - or the limit, if there are no more movable objects, or 0 if no more compaction can be - done. Compaction is done when the search through the freeList has reached the - address from which objects are being moved from. - - There are two broad cases to be dealt with here. One is a run of smallish objects - that can easily be moved into free chunks. The other is a large object that is unlikely - to fit in the typical free chunk. This second pig needs careful handling; it needs to be - moved to the lowest place it will fit and not cause the scan to skip lots of smaller - free chunks looking in vain for somewhere to put it." - <var: #startAddress type: #usqInt> - <var: #limit type: #usqInt> - <inline: false> - | here hereObj hereObjHeader prevPrevFreeChunk prevFreeChunk thisFreeChunk maxFreeChunk | - <var: #here type: #usqInt> - <var: #there type: #usqInt> - <var: #nextFree type: #usqInt> - <var: #endOfFree type: #usqInt> - <var: #destination type: #usqInt> - <var: #maxFreeChunk type: #usqInt> - here := startAddress. - hereObj := manager objectStartingAt: startAddress. - hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj. - prevPrevFreeChunk := prevFreeChunk := 0. - thisFreeChunk := maxFreeChunk := firstFreeChunk. - [thisFreeChunk ~= 0] whileTrue: - [| freeBytes endOfFree nextFree destination there moved | - - "skip any initial immobile objects" - [(manager isMobileObjectHeader: hereObjHeader)] whileFalse: - [here := manager addressAfter: hereObj. - here >= limit ifTrue: - [^maxFreeChunk >= startAddress ifTrue: [0] ifFalse: [limit]]. - hereObj := manager objectStartingAt: here. - hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj]. - - "grab a free chunk, and the following one, because we want to overwrite this one." - self assert: ((manager isFreeObject: firstFreeChunk) and: [manager isFreeObject: thisFreeChunk]). - freeBytes := manager bytesInObject: thisFreeChunk. - nextFree := self nextInSortedFreeListLink: thisFreeChunk given: prevFreeChunk. - destination := manager startOfObject: thisFreeChunk. - endOfFree := destination + freeBytes. - moved := false. - maxFreeChunk := maxFreeChunk max: nextFree. - self assert: (nextFree = 0 or: [manager isFreeObject: nextFree]). - - "move as many objects as will fit in freeBytes..." - [there := manager addressAfter: hereObj. - "N.B. *must* add allocationUnit, not subtract, to avoid unsigned arithmetic issues when freeBytes = 0" - (manager isMobileObjectHeader: hereObjHeader) - and: [freeBytes > (there - here + manager allocationUnit) - or: [freeBytes = (there - here)]]] whileTrue: - [moved := true. - manager mem: destination asVoidPointer cp: here asVoidPointer y: there - here. - manager forwardUnchecked: hereObj to: destination + (hereObj - here). - destination := destination + (there - here). - freeBytes := freeBytes - (there - here). - hereObj := manager objectStartingAt: there. - here := there. - hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj]. - - moved - ifTrue: "we did overwrite it; we need to repair the free list" - [| nextNextFree | - nextFree ~= 0 ifTrue: - [nextNextFree := self nextInSortedFreeListLink: nextFree given: thisFreeChunk. - self assert: (manager isFreeObject: nextFree)]. - (destination > thisFreeChunk "if false couldn't move anything" - and: [destination < endOfFree]) "if false, filled entire free chunk" - ifTrue: - [thisFreeChunk := manager initFreeChunkWithBytes: endOfFree - destination at: destination. - self inSortedFreeListLink: prevFreeChunk to: thisFreeChunk given: prevPrevFreeChunk. - self inSortedFreeListLink: thisFreeChunk to: nextFree given: prevFreeChunk. - nextFree ~= 0 ifTrue: - [self inSortedFreeListLink: nextFree to: nextNextFree given: thisFreeChunk]. - prevPrevFreeChunk := prevFreeChunk. - prevFreeChunk := thisFreeChunk. - thisFreeChunk := nextFree] - ifFalse: - [self inSortedFreeListLink: prevFreeChunk to: nextFree given: prevPrevFreeChunk. - nextFree ~= 0 ifTrue: - [self inSortedFreeListLink: nextFree to: nextNextFree given: prevFreeChunk]. - thisFreeChunk := nextFree]] - ifFalse: "out of space (or immobile object); move on up the free list..." - [prevPrevFreeChunk := prevFreeChunk. - prevFreeChunk := thisFreeChunk. - thisFreeChunk := nextFree]. - - (manager isMobileObjectHeader: hereObjHeader) ifFalse: - [^maxFreeChunk >= startAddress ifTrue: [0] ifFalse: [there]]. - - "Was the loop stopped by a pig? If so, try and find space for it" - there - here >= (manager averageObjectSizeInBytes * 8) ifTrue: "256b in 32 bit, 512b in 64 bit" - [| usedChunk | - usedChunk := self tryToMovePig: hereObj at: here end: there. - "if it couldn't be moved we need to advance, so always - set here to there whether the pig was moved or not." - hereObj := manager objectStartingAt: there. - here := there. - hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj. - "In general it's a bad idea to reset the enumeration; it leads to N^2 behaviour - when encountering pigs. But if the move affected the enumeration this is - simpler than resetting the list pointers." - (usedChunk = prevPrevFreeChunk - or: [usedChunk = prevFreeChunk - or: [usedChunk = thisFreeChunk]]) ifTrue: - ["reset the scan for free space back to the start of the list" - prevPrevFreeChunk := prevFreeChunk := 0. - thisFreeChunk := firstFreeChunk]]. - - ((here > startAddress and: [there >= limit]) - or: [maxFreeChunk >= startAddress]) ifTrue: - [^maxFreeChunk >= startAddress ifTrue: [0] ifFalse: [there]]]. - ^here! Item was removed: - ----- Method: SpurPigCompactor>>nextInSortedFreeListLink:given: (in category 'compaction') ----- - nextInSortedFreeListLink: freeChunk given: prevFree - "Answer the next free free chunk using the xor trick to use only one field, see e.g. - The Art of Computer Programming, Vol 1, D.E. Knuth, 3rd Ed, Sec 2.2.4 `Circular Lists', exercise. 18 - http://en.wikipedia.org/wiki/XOR_linked_list." - <inline: true> - ^((manager fetchPointer: manager freeChunkNextIndex ofFreeChunk: freeChunk) bitXor: prevFree) asUnsignedInteger! Item was removed: - ----- Method: SpurPigCompactor>>noForwardersBelowFirstFreeChunk (in category 'compaction - asserts') ----- - noForwardersBelowFirstFreeChunk - manager allOldSpaceEntitiesDo: - [:o| - (self oop: o isGreaterThanOrEqualTo: firstFreeChunk) ifTrue: - [^true]. - (manager isForwarded: o) ifTrue: - [^false]]. - ^true! Item was removed: - ----- Method: SpurPigCompactor>>pigCompact (in category 'compaction') ----- - pigCompact - "Traverse the sorted free list, moving objects from the high-end of - memory to the free objects in the low end of memory. Return when - the address at which objects are being copied to meets the address - from which objects are being copied from." - self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: 'pig compacting...'; flush]. - self sortedFreeListPairwiseReverseDo: - [:low :high| | scanAddress | - self cCode: '' inSmalltalk: [coInterpreter transcript nextPut: $.; flush]. - scanAddress := manager addressAfter: low. - [self oop: scanAddress isLessThan: high] whileTrue: - [scanAddress := self moveARunOfObjectsStartingAt: scanAddress upTo: high. - scanAddress = 0 ifTrue: - [^self]]]. - self assert: self checkTraversableSortedFreeList! Item was removed: - ----- Method: SpurPigCompactor>>printSortedFreeList (in category 'debug printing') ----- - printSortedFreeList - <api> - | freeChunk prevFree nextFree | - (firstFreeChunk > 0 and: [lastFreeChunk > firstFreeChunk]) ifFalse: - [coInterpreter print: 'sorted free list empty or corrupt'; cr. - ^self]. - freeChunk := firstFreeChunk. - prevFree := 0. - [((manager addressCouldBeObj: freeChunk) - and: [manager isFreeObject: freeChunk]) ifFalse: - [coInterpreter printHexnp: freeChunk; print: ' is not a free chunk!!' ; cr. - ^self]. - manager printFreeChunk: freeChunk printAsTreeNode: false. - freeChunk ~= lastFreeChunk] whileTrue: - [nextFree := self nextInSortedFreeListLink: freeChunk given: prevFree. - prevFree := freeChunk. - freeChunk := nextFree]! Item was removed: - ----- Method: SpurPigCompactor>>rebuildFreeListsForPigCompact (in category 'compaction') ----- - rebuildFreeListsForPigCompact - "Rebuild the free lists from the doubly-linked free list." - <inline: false> - self assert: self checkTraversableSortedFreeList. - manager totalFreeOldSpace: 0. - self sortedFreeListDo: - [:freeObj| | start bytes | - bytes := (manager bytesInObject: freeObj). - start := manager startOfObject: freeObj. - manager addFreeChunkWithBytes: bytes at: start]. - manager checkFreeSpace: GCModeFull! Item was removed: - ----- Method: SpurPigCompactor>>sortedFreeListDo: (in category 'compaction') ----- - sortedFreeListDo: aBlock - "Evaluate aBlock with ascending entries in the free list" - | free nextFree prevFree prevPrevFree | - <var: #free type: #usqInt> - <var: #nextFree type: #usqInt> - <var: #prevFree type: #usqInt> - <var: #prevPrevFree type: #usqInt> - <inline: true> - free := firstFreeChunk. - prevPrevFree := prevFree := 0. - [free ~= 0] whileTrue: - [nextFree := self nextInSortedFreeListLink: free given: prevFree. - self assert: (manager isFreeObject: free). - self assert: (nextFree = 0 or: [nextFree > free and: [manager isFreeObject: nextFree]]). - self assert: (prevFree = 0 or: [prevFree < free]). - aBlock value: free. - prevPrevFree := prevFree. - prevFree := free. - free := nextFree]! Item was removed: - ----- Method: SpurPigCompactor>>sortedFreeListPairwiseReverseDo: (in category 'compaction') ----- - sortedFreeListPairwiseReverseDo: aBinaryBlock - "Evaluate aBinaryBlock with adjacent entries in the free list, from - high address to low address. The second argument is in fact the - start of the next free chunk, not the free chunk itself. Use - endOfMemory - bridgeSize as the second argument in the first evaluation." - | free prevFree prevPrevFree | - <var: #free type: #usqInt> - <var: #prevFree type: #usqInt> - <var: #prevPrevFree type: #usqInt> - <inline: true> - free := lastFreeChunk. - prevPrevFree := prevFree := 0. - [free ~= 0] whileTrue: - [aBinaryBlock value: free value: (prevFree = 0 - ifTrue: [manager endOfMemory - manager bridgeSize] - ifFalse: [manager startOfObject: prevFree]). - "post evaluation of aBinaryBlock the value of free may be invalid - because moveARunOfObjectsStartingAt:upTo: may have filled it. - So reconstruct the position in the enumeration." - prevFree = 0 - ifTrue: - [self assert: free = lastFreeChunk. - prevFree := lastFreeChunk. - free := self nextInSortedFreeListLink: lastFreeChunk given: 0] - ifFalse: - [self assert: (manager isFreeObject: prevFree). - prevPrevFree = 0 - ifTrue: - [prevPrevFree := lastFreeChunk. - prevFree := self nextInSortedFreeListLink: lastFreeChunk given: 0] - ifFalse: - [self assert: (manager isFreeObject: prevPrevFree). - free := self nextInSortedFreeListLink: prevFree given: prevPrevFree. - prevPrevFree := prevFree. - prevFree := free]. - free := self nextInSortedFreeListLink: prevFree given: prevPrevFree]]! Item was removed: - ----- Method: SpurPigCompactor>>sweepToCoallesceFreeSpaceForPigCompactFrom: (in category 'compaction') ----- - sweepToCoallesceFreeSpaceForPigCompactFrom: lowestForwarder - "Coallesce free chunks and forwarders, maintaining the doubly-linked free list." - | lowest firstOfFreeRun startOfFreeRun endOfFreeRun prevPrevFree prevFree | - <var: #lowestForwarder type: #usqInt> - lowest := (lowestForwarder = 0 ifTrue: [manager endOfMemory] ifFalse: [lowestForwarder]) - min: (firstFreeChunk = 0 ifTrue: [manager endOfMemory] ifFalse: [firstFreeChunk]). - firstOfFreeRun := prevPrevFree := prevFree := 0. - manager allOldSpaceEntitiesFrom: lowest do: - [:o| - ((manager isFreeObject: o) or: [manager isForwarded: o]) - ifTrue: - [firstOfFreeRun = 0 ifTrue: - [manager setObjectFree: o. - firstOfFreeRun := o. - startOfFreeRun := manager startOfObject: o]. - endOfFreeRun := o] - ifFalse: - [firstOfFreeRun ~= 0 ifTrue: - [| bytes | - bytes := (manager addressAfter: endOfFreeRun) - startOfFreeRun. - firstOfFreeRun := manager initFreeChunkWithBytes: bytes at: startOfFreeRun. - self inSortedFreeListLink: prevFree to: firstOfFreeRun given: prevPrevFree. - prevPrevFree := prevFree. - prevFree := firstOfFreeRun. - firstOfFreeRun := 0]]]. - firstOfFreeRun ~= 0 ifTrue: - [| bytes | - bytes := (manager addressAfter: endOfFreeRun) - startOfFreeRun. - firstOfFreeRun := manager initFreeChunkWithBytes: bytes at: startOfFreeRun. - self inSortedFreeListLink: prevFree to: firstOfFreeRun given: prevPrevFree. - prevPrevFree := prevFree. - prevFree := firstOfFreeRun. - firstOfFreeRun := 0]. - prevFree ~= firstFreeChunk ifTrue: - [manager storePointer: manager freeChunkNextIndex - ofFreeChunk: prevFree - withValue: prevPrevFree]. - lastFreeChunk := prevFree. - self inSortedFreeListLink: lastFreeChunk to: 0 given: prevPrevFree. - self assert: self checkTraversableSortedFreeList! Item was removed: - ----- Method: SpurPigCompactor>>sweepToFollowForwardersForPigCompact (in category 'compaction') ----- - sweepToFollowForwardersForPigCompact - "Sweep, following forwarders in all live objects. - Answer the lowest forwarder in oldSpace." - | lowestForwarder | - <var: #lowestForwarder type: #usqInt> - self assert: (manager freeStart = scavenger eden start - and: [scavenger futureSurvivorStart = scavenger futureSpace start]). - manager allPastSpaceObjectsDo: - [:o| - (manager isForwarded: o) ifFalse: - [0 to: (manager numPointerSlotsOf: o) - 1 do: - [:i| | f | - f := manager fetchPointer: i ofObject: o. - (manager isOopForwarded: f) ifTrue: - [f := manager followForwarded: f. - manager storePointerUnchecked: i ofObject: o withValue: f]]]]. - lowestForwarder := 0. - manager allOldSpaceObjectsDo: - [:o| - (manager isForwarded: o) - ifTrue: - [lowestForwarder = 0 ifTrue: - [lowestForwarder := o]] - ifFalse: - [0 to: (manager numPointerSlotsOf: o) - 1 do: - [:i| | f | - f := manager fetchPointer: i ofObject: o. - (manager isOopForwarded: f) ifTrue: - [f := manager followForwarded: f. - manager storePointer: i ofObject: o withValue: f]]]]. - ^lowestForwarder! Item was removed: - ----- Method: SpurPigCompactor>>tryToMovePig:at:end: (in category 'compaction') ----- - tryToMovePig: pigObj at: pigStart end: pigEnd - "Try to move a pig (a largish object) to a free chunk in low memory. - Answer the freeChunk that was used to house the moved pig, or - 0 if no free chunk could be found." - | freeChunk prevFree prevPrevFree pigBytes nextNext | - prevPrevFree := prevFree := 0. - freeChunk := firstFreeChunk. - pigBytes := pigEnd - pigStart. - [freeChunk ~= 0 and: [freeChunk < pigObj]] whileTrue: - [| next dest chunkBytes newChunk | - next := self nextInSortedFreeListLink: freeChunk given: prevFree. - dest := manager startOfObject: freeChunk. - chunkBytes := (manager addressAfter: freeChunk) - dest. - "N.B. *must* add allocationUnit, not subtract, to avoid unsigned arithmetic issues when chunkBytes = 0" - (chunkBytes = pigBytes - or: [chunkBytes > (pigBytes + manager allocationUnit)]) ifTrue: - [manager mem: dest asVoidPointer cp: pigStart asVoidPointer y: pigBytes. - manager forwardUnchecked: pigObj to: dest + (pigObj - pigStart). - next ~= 0 ifTrue: - [nextNext := self nextInSortedFreeListLink: next given: freeChunk]. - "now either shorten the chunk, or remove it, adjusting the links to keep the list sorted." - pigBytes < chunkBytes "if false, filled entire free chunk" - ifTrue: - [newChunk := manager initFreeChunkWithBytes: chunkBytes - pigBytes at: dest + pigBytes. - self inSortedFreeListLink: prevFree to: newChunk given: prevPrevFree. - self inSortedFreeListLink: newChunk to: next given: prevFree. - next ~= 0 ifTrue: - [self inSortedFreeListLink: next to: nextNext given: newChunk]] - ifFalse: - [self inSortedFreeListLink: prevFree to: next given: prevPrevFree. - next ~= 0 ifTrue: - [self inSortedFreeListLink: next to: nextNext given: prevFree]]. - "self checkTraversableSortedFreeList". - ^freeChunk]. - prevPrevFree := prevFree. - prevFree := freeChunk. - freeChunk := next]. - ^0! Item was changed: ----- Method: SpurPlanningCompactor>>coalesceFrom: (in category 'private') ----- coalesceFrom: maybeStartOfFree "manager printOopsFrom: maybeStartOfFree to: manager endOfMemory" <var: 'maybeStartOfFree' type: #usqInt> + |obj next objBytes nextBytes| - | obj next | <var: 'obj' type: #usqInt> <var: 'next' type: #usqInt> maybeStartOfFree >= manager endOfMemory ifTrue: [^self]. obj := manager objectStartingAt: maybeStartOfFree. [next := manager oldSpaceObjectAfter: obj. next < manager endOfMemory] whileTrue: [((manager isFreeObject: obj) and: [manager isFreeObject: next]) ifTrue: + [objBytes := manager bytesInObject: obj. + nextBytes := manager bytesInObject: next. + manager unlinkFreeChunk: obj chunkBytes: objBytes. + manager unlinkFreeChunk: next chunkBytes: nextBytes. + obj := manager freeChunkWithBytes: objBytes + nextBytes at: (manager startOfObject: obj)] - [manager unlinkFreeChunk: obj. - manager unlinkFreeChunk: next. - obj := manager freeChunkWithBytes: (manager bytesInObject: obj) + (manager bytesInObject: next) at: (manager startOfObject: obj)] ifFalse: [obj := next]]! Item was changed: ----- Method: SpurSelectiveCompactor>>globalSweepAndSegmentOccupationAnalysis (in category 'sweep phase') ----- globalSweepAndSegmentOccupationAnalysis self internalGlobalSweepAndSegmentOccupationAnalysis. manager checkFreeSpace: GCModeFull. + manager unmarkSurvivingObjectsForCompact. + self cCode: '' inSmalltalk: [manager freeTreeOverlapCheck].! - manager unmarkSurvivingObjectsForCompact.! Item was changed: ----- Method: SpurSelectiveCompactor>>selectiveCompaction (in category 'compaction') ----- selectiveCompaction "Figures out which segments to compact and compact them into segmentToFill" | atLeastOneSegmentToCompact | self assertNoSegmentBeingCompacted. atLeastOneSegmentToCompact := self computeSegmentsToCompact. "If no compaction we don't pay forwarding cost (stack scan, cache scan, etc.) and we don't allocate segmentToFill if none available." atLeastOneSegmentToCompact ifTrue: [self assert: segmentToFill ~~ nil. + self compactSegmentsToCompact. + self cCode: '' inSmalltalk: [manager freeTreeOverlapCheck].]. - self compactSegmentsToCompact]. manager checkFreeSpace: GCModeFull.! Item was changed: ----- Method: SpurSweeper>>globalSweep (in category 'sweep phase') ----- globalSweep "Iterate over all entities, in order, if the entity is a free chunk or unmarked object, make a new big piece of free chunk, else unmark the object which stay live." | currentEntity start | currentEntity := manager firstObject. [self oop: currentEntity isLessThan: manager endOfMemory] whileTrue: [(self canUseAsFreeSpace: currentEntity) ifTrue: ["bulkFreeChunkFrom: may change a 1 word header object to a double word header object" start := manager startOfObject: currentEntity. self bulkFreeChunkFrom: currentEntity. currentEntity := manager objectStartingAt: start] ifFalse: [self unmark: currentEntity]. currentEntity := manager objectAfter: currentEntity limit: manager endOfMemory]. manager checkFreeSpace: GCModeFull. manager unmarkSurvivingObjectsForCompact. + + self cCode: '' inSmalltalk: [manager freeTreeOverlapCheck]. !

1 0

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

07 Jun '18

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2404.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.2404 Author: eem Time: 6 June 2018, 8:50:34.703258 pm UUID: 95c23edd-e78a-43a0-a3cf-408e3838ce84 Ancestors: VMMaker.oscog-eem.2403 Spur Compaction & Slang Add support for static resolution of very limited polymorphism, specifically that required to select between the SpurSelectiveCompactor and the SpurPlanningCompactor at run-time, using SpurSelectiveCompactor for normal GC and SpurPlanningCompactor for snapshots. SpurHybridCompactor is the compactorClass that selects between these two, based on its planNotSelect instance variable. CCodeGenerator gets a staticallyResolvedPolymorphicReceivers dictionary that aps variable names to classes, and hence SpurHybridCompactor maps planningCompactor to SpurPlanningCompactor and selectiveCompactor to SpurSelectiveCompactor. Mapping of the selectors happens in TMethod>>prepareMethodIn: via CCodeGenerator>>ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn:. All the ugliness is in SpurCompa tor class and subclass implementations of declareCVarsIn:, where we have to map the methods themselves, mapping the API (e.g. SpurPlanningCompactor>>compact to SpurPlanningCompactor>>SPC_compact, and SpurSelectiveCompactor>>compact to SpurSelectiveCompactor>>SS_compact, because SpurSelectiveCompactor inherits from SpurSweeper and mapping things twice (once from compact to SS_compact and then subsequently from SS_compact to SSC_compact) is too tricky, whereas mapping all SpurSelectiveCompactor API methods to SS_... is much easier. Remove the otherwise unreferenced biasForGC inst var from SpurSweeper because the Slang static resolution mechanism currently only supports name mangling of selectors, not instance variables. If and when we need this we can implement it, but for the moment KISS. To generate a VM using SpurHybridCompactor siomply set the compactorClass SpurHybridCompactor option in the VMMaker options, e.g. generateSqueakSpurCog64VM "No primitives since we can use those for the Cog VM" ^VMMaker generate: CoInterpreter and: StackToRegisterMappingCogit with: #(ObjectMemory Spur64BitCoMemoryManager compactorClass SpurHybridCompactor MULTIPLEBYTECODESETS true bytecodeTableInitializer initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid) to: (FileDirectory default pathFromURI: self sourceTree, '/spur64src') platformDir: (FileDirectory default pathFromURI: self sourceTree, '/platforms') including:#() WARNING Will Robinson! I have only tested the Slang generation and VM compilation. I jhave not checked whether this runs in the simulator yet. Yes, that's backwards, but I expect this is far enough along that getting the sdimulator to work should be easy; it's the simple bit. =============== Diff against VMMaker.oscog-eem.2403 =============== 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 optionsDictionary breakSrcInlineSelectors breakDestInlineSelectors breakOnInline vmMaker' - 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 optionsDictionary breakSrcInlineSelectors breakDestInlineSelectors breakOnInline vmMaker' classVariableNames: 'NoRegParmsInAssertVMs' 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 added: + ----- Method: CCodeGenerator>>ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn: (in category 'public') ----- + ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn: aSendNode + "We allow a limited amount of polymorphism; if a class chooses, its selectoers 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." + | class | + staticallyResolvedPolymorphicReceivers ifNil: [^self]. + aSendNode receiver isVariable ifFalse: + [^self]. + class := staticallyResolvedPolymorphicReceivers + at: aSendNode receiver name + ifAbsent: [^self]. + aSendNode selector: (class staticallyResolvePolymorphicSelector: aSendNode selector)! Item was added: + ----- Method: CCodeGenerator>>methodsForDefiningClass: (in category 'utilities') ----- + methodsForDefiningClass: dc + "Answer a collection of methods that refer to the given global variable." + + ^methods select: [:tMethod| tMethod definingClass == dc]! Item was added: + ----- 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 selectoers 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 logger cr; nextPutAll: 'warning: did not find ', selector, ' to be able to map to ', staticallyResolvedSelector. + ^self]. + method selector: staticallyResolvedSelector. + methods at: staticallyResolvedSelector put: method! Item was added: + ----- Method: CCodeGenerator>>staticallyResolvedPolymorphicReceiver:to: (in category 'public') ----- + staticallyResolvedPolymorphicReceiver: variableName to: aClass + "We allow a limited amount of polymorphism; if a class chooses, its selectoers 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: variableName + put: aClass! Item was changed: TMethod subclass: #SmartSyntaxPluginTMethod instanceVariableNames: 'isPrimitive suppressingFailureGuards fullSelector fullArgs parmSpecs rcvrSpec' classVariableNames: '' poolDictionaries: '' category: 'VMMaker-SmartSyntaxPlugins'! + !SmartSyntaxPluginTMethod commentStamp: 'eem 6/6/2018 14:06' prior: 0! + Variation of TMethod node of the Smalltalk C Code Generator, used in conjunction with SmartSyntaxPluginCodeGenerator and SmartSyntaxInterpreterPlugin to generate named primitives from methods containing type coercion specifications such as + primitive: functionName parameters: #(Boolean Oop String WordsArray WordsOrBytes) + primitive: functionName parameters: #(SmallInteger LargeNegativeInteger LargePositiveInteger Integer Unsigned) receiver: #Oop! - !SmartSyntaxPluginTMethod commentStamp: '<historical>' prior: 0! - Variation of TMethod node of the Smalltalk C Code Generator, used in conjunction with TestCodeGenerator and TestInterpreterPlugin to generate named primitives with type coercion specifications.! Item was changed: + ----- Method: SmartSyntaxPluginTMethod>>fromContext:primitive:parameters:receiver: (in category 'initialization') ----- - ----- Method: SmartSyntaxPluginTMethod>>fromContext:primitive:parameters:receiver: (in category 'initializing') ----- fromContext: aContext primitive: aString parameters: aClassList receiver: aClass fullArgs := args := aContext tempNames copyFrom: 1 to: aContext method numArgs. self primitive: aString parameters: aClassList receiver: aClass! Item was changed: + ----- Method: SmartSyntaxPluginTMethod>>setSelector:definingClass:args:locals:block:primitive:properties:comment: (in category 'initialization') ----- - ----- Method: SmartSyntaxPluginTMethod>>setSelector:definingClass:args:locals:block:primitive:properties:comment: (in category 'initializing') ----- setSelector: sel definingClass: class args: argList locals: localList block: aBlockNode primitive: aNumber properties: methodProperties comment: aComment "Initialize this method using the given information." selector := sel. definingClass := class. returnType := #sqInt. "assume return type is sqInt for now" args := argList asOrderedCollection collect: [:arg | arg key]. locals := (localList collect: [:arg | arg key]) asSet. declarations := Dictionary new. primitive := aNumber. properties := methodProperties. comment := aComment. parseTree := aBlockNode asTranslatorNodeIn: self. labels := Set new. complete := false. "set to true when all possible inlining has been done" export := self extractExportDirective. static := self extractStaticDirective. self extractSharedCase. isPrimitive := false. "set to true only if you find a primtive direction." suppressingFailureGuards := self extractSuppressFailureGuardDirective. self recordDeclarationsIn: nil. self extractPrimitiveDirectives. ! Item was added: + ----- Method: SpurCompactor class>>classesForTranslation (in category 'translation') ----- + classesForTranslation + ^(self withAllSuperclasses copyUpThrough: SpurCompactor) reverse! Item was added: + ----- Method: SpurCompactor class>>declareCVarsIn: (in category 'translation') ----- + declareCVarsIn: aCCodeGenerator + "If subclasses are being used but are not the compactorClass itself + then staticvally resolve their api selectors." + ((self inheritsFrom: SpurCompactor) + and: [(initializationOptions at: #compactorClass) ~= self name]) ifTrue: + [#(compact biasForGC biasForSnapshot remapObj: shouldRemapObj:) do: + [:selectorToStaticallyResolve| + aCCodeGenerator + staticallyResolveMethodNamed: selectorToStaticallyResolve + forClass: self + to: (self staticallyResolvePolymorphicSelector: selectorToStaticallyResolve)]]! Item was changed: + ----- Method: SpurCompactor class>>implicitReturnTypeFor: (in category 'translation') ----- - ----- Method: SpurCompactor class>>implicitReturnTypeFor: (in category 'as yet unclassified') ----- implicitReturnTypeFor: aSelector "Answer the return type for methods that don't have an explicit return." ^#void! Item was added: + ----- Method: SpurCompactor>>scavenger: (in category 'initialization') ----- + scavenger: aSpurGenerationScavenger + <doNotGenerate> + scavenger := aSpurGenerationScavenger! Item was added: + SpurCompactor subclass: #SpurHybridCompactor + instanceVariableNames: 'planningCompactor selectiveCompactor planNotSelect' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-SpurMemoryManager'! + + !SpurHybridCompactor commentStamp: 'eem 6/6/2018 19:25' prior: 0! + A SpurHybridCompactor is a compactor that uses SpurSelectiveCompactor for normal GC compactions, but uses SpurPlanningCompactor for snapshot. + + Instance Variables + planNotSelect: <Boolean> + planningCompactor: <SpurPlanningCompactor> + selectiveCompactor: <SpurSelectiveCompactor> + + planNotSelect + - the boolean that selects between the two compactors; if true it chooses SpurPlanningCompactor + + planningCompactor + - the SpurPlanningCompactor + + selectiveCompactor + - the SpurSelectiveCompactor + ! Item was added: + ----- Method: SpurHybridCompactor class>>ancilliaryClasses: (in category 'translation') ----- + ancilliaryClasses: options + "Answer any extra classes to be included in the translation." + ^{ SpurPlanningCompactor. + SpurSelectiveCompactor. + SpurSweeper }! Item was added: + ----- Method: SpurHybridCompactor class>>classesForTranslation (in category 'translation') ----- + classesForTranslation + ^(self ancilliaryClasses: nil), super classesForTranslation! Item was added: + ----- Method: SpurHybridCompactor class>>declareCVarsIn: (in category 'translation') ----- + declareCVarsIn: aCCodeGenerator + aCCodeGenerator + staticallyResolvedPolymorphicReceiver: 'planningCompactor' to: SpurPlanningCompactor; + staticallyResolvedPolymorphicReceiver: 'selectiveCompactor' to: SpurSweeper"SpurSelectiveCompactor" "The selector mangling is easier this way"! Item was added: + ----- Method: SpurHybridCompactor>>biasForGC (in category 'api') ----- + biasForGC + planNotSelect := false. + selectiveCompactor biasForGC! Item was added: + ----- Method: SpurHybridCompactor>>biasForSnapshot (in category 'api') ----- + biasForSnapshot + planNotSelect := true. + planningCompactor biasForSnapshot! Item was added: + ----- Method: SpurHybridCompactor>>coInterpreter: (in category 'initialization') ----- + coInterpreter: aVMSimulator + <doNotGenerate> + super coInterpreter: aVMSimulator. + planningCompactor coInterpreter: aVMSimulator. + selectiveCompactor coInterpreter: aVMSimulator! Item was added: + ----- Method: SpurHybridCompactor>>compact (in category 'api') ----- + compact + planNotSelect + ifTrue: [planningCompactor compact] + ifFalse: [selectiveCompactor compact]! Item was added: + ----- Method: SpurHybridCompactor>>manager: (in category 'initialization') ----- + manager: aSpurNBitMMXEndianSimulator + <doNotGenerate> + super manager: aSpurNBitMMXEndianSimulator. + (planningCompactor ifNil: [planningCompactor := SpurPlanningCompactor simulatorClass new]) + manager: aSpurNBitMMXEndianSimulator. + (selectiveCompactor ifNil: [selectiveCompactor := SpurSelectiveCompactor simulatorClass new]) + manager: aSpurNBitMMXEndianSimulator. + + planNotSelect := false! Item was added: + ----- Method: SpurHybridCompactor>>remapObj: (in category 'api') ----- + remapObj: objOop + <api> + <inline: false> + planNotSelect ifTrue: + [^manager slidingCompactionRemapObj: objOop]. + ^super remapObj: objOop! Item was added: + ----- Method: SpurHybridCompactor>>scavenger: (in category 'initialization') ----- + scavenger: aSpurGenerationScavenger + <doNotGenerate> + super scavenger: aSpurGenerationScavenger. "I always thought the scavenger was super..." + planningCompactor scavenger: aSpurGenerationScavenger. + selectiveCompactor scavenger: aSpurGenerationScavenger! Item was added: + ----- Method: SpurHybridCompactor>>shouldRemapObj: (in category 'api') ----- + shouldRemapObj: objOop + <api> + <inline: false> + planNotSelect ifTrue: + [^manager slidingCompactionShouldRemapObj: objOop]. + ^super shouldRemapObj: objOop! Item was changed: ----- Method: SpurMemoryManager class>>ancilliaryClasses: (in category 'translation') ----- ancilliaryClasses: options initializationOptions ifNil: [initializationOptions := options]. ^{ SpurGenerationScavenger. SpurScavengeLogRecord. SpurSegmentManager. SpurSegmentInfo }, + self compactorClass classesForTranslation, - (self compactorClass withAllSuperclasses copyUpThrough: SpurCompactor) reverse, SpurNewSpaceSpace withAllSubclasses ! Item was changed: ----- Method: SpurMemoryManager class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') ----- isNonArgumentImplicitReceiverVariableName: aString + ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager' 'compactor' 'planningCompactor' 'selectiveCompactor' 'heapMap') includes: aString! - ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager' 'compactor' 'heapMap') includes: aString! Item was changed: ----- Method: SpurPlanningCompactor class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator + super declareCVarsIn: aCCodeGenerator. self declareCAsOop: (self instVarNames select: [:iv| iv endsWith: 'Object']) in: aCCodeGenerator. aCCodeGenerator var: 'savedFirstFieldsSpace' type: #SpurContiguousObjStack! Item was changed: ----- Method: SpurSelectiveCompactor class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator + super declareCVarsIn: aCCodeGenerator. aCCodeGenerator var: 'segmentToFill' type: #'SpurSegmentInfo *'! Item was changed: ----- Method: SpurSelectiveCompactor>>findNextSegmentToCompact (in category 'compaction') ----- findNextSegmentToCompact "Answers the next segment to compact or nil if none. The next segment to compact: - cannot be segment 0 (Segment 0 has specific objects (nil, true, etc.) and special size computed at start-up that we don't want to deal with) - cannot have a high occupation rate (> MaxOccupationForCompaction)" | leastOccupied leastOccupiedSegment tempOccupied segInfo | <var: 'segInfo' type: #'SpurSegmentInfo *'> leastOccupied := 16rFFFF. 1 to: manager numSegments - 1 do: [:i| segInfo := self addressOf: (manager segmentManager segments at: i). ((self isSegmentBeingCompacted: segInfo) or: [segInfo containsPinned or: [manager segmentManager isEmptySegment: segInfo] ]) ifFalse: [(tempOccupied := self occupationOf: segInfo) <= leastOccupied ifTrue: [ leastOccupied := tempOccupied. leastOccupiedSegment := segInfo ]]]. + leastOccupied > MaxOccupationForCompaction ifTrue: + [^self cCoerceSimple: nil to: #'SpurSegmentInfo *']. + ^leastOccupiedSegment! - leastOccupied > MaxOccupationForCompaction ifTrue: [^nil]. - ^ leastOccupiedSegment! Item was changed: ----- Method: SpurSelectiveCompactor>>postSwizzleAction (in category 'api') ----- postSwizzleAction + "Since the compact abuses the swizzle field of segment, it needs to be reset after start-up." - "Since the compact abuses the swizzle field of segment, it needs to be rest after start-up." | segInfo | <var: 'segInfo' type: #'SpurSegmentInfo *'> 0 to: manager numSegments - 1 do: [:i| segInfo := self addressOf: (manager segmentManager segments at: i). segInfo swizzle: 0 ]! Item was changed: SpurCompactor subclass: #SpurSweeper + instanceVariableNames: '' - instanceVariableNames: 'biasForGC' classVariableNames: '' poolDictionaries: '' category: 'VMMaker-SpurMemoryManager'! !SpurSweeper commentStamp: 'cb 4/27/2018 09:43' prior: 0! SpurSweeper is a sweep-only algorithm, setting the compactor to SpurSweeper effectively changes the fullGC to a mark-sweep non-moving algorithm. SpurSweeper is a reference implementation if one wants to evaluate GC performance and compare it to a Mark-Sweep. It's also the only non-moving GC available right now which can be convenient for some experiments. One of the main reason why it was implemented is because advanced compaction algorithm includes a sweep phase (See SelectiveCompactor for example) and SpurSweeper allows to debug the sweep phase separatedly. ! Item was changed: ----- Method: SpurSweeper>>biasForGC (in category 'api') ----- + biasForGC! - biasForGC - biasForGC := true.! Item was changed: ----- Method: SpurSweeper>>biasForSnapshot (in category 'api') ----- + biasForSnapshot! - biasForSnapshot - biasForGC := false.! Item was changed: + ----- Method: TMethod>>addTypeForSelf (in category 'initialization') ----- - ----- Method: TMethod>>addTypeForSelf (in category 'utilities') ----- addTypeForSelf "If self should be typed then add a suitable type declaration. Preserve the flagging of an implicit self using the #implicit symbol as the fake type." self typeForSelf ifNotNil: [:typeForSelf| self declarationAt: 'self' put: (typeForSelf == #implicit ifTrue: [typeForSelf] ifFalse: [typeForSelf, ' self'])]! Item was changed: ----- Method: TMethod>>prepareMethodIn: (in category 'transformations') ----- prepareMethodIn: aCodeGen "Record sends of builtin operators, map sends of the special selector dispatchOn:in: with case statement nodes, and map sends of caseOf:[otherwise:] to switch statements. Declare limit variables for to:[by:]do: loops with limits that potentially have side-effects. As a hack also update the types of variables introduced to implement cascades correctly. This has to be done at the same time as this is done, so why not piggy back here?" extraVariableNumber ifNotNil: [declarations keysAndValuesDo: [:varName :decl| decl isBlock ifTrue: [self assert: ((varName beginsWith: 'cascade') and: [varName last isDigit]). locals add: varName. self declarationAt: varName put: (decl value: self value: aCodeGen), ' ', varName]]]. aCodeGen pushScope: declarations while:"N.B. nodesWithParentsDo: is bottom-up, hence replacement is destructive and conserved." [parseTree nodesWithParentsDo: [:node :parent| node isSend ifTrue: + [aCodeGen ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn: node. + (aCodeGen isBuiltinSelector: node selector) - [(aCodeGen isBuiltinSelector: node selector) ifTrue: [node isBuiltinOperator: true. "If a to:by:do:'s limit has side-effects, declare the limit variable, otherwise delete it from the args" node selector = #to:by:do: ifTrue: [self ensureToByDoLoopLimitIsSafeAndEfficient: node in: aCodeGen]] ifFalse: [(CaseStatements includes: node selector) ifTrue: [parent replaceNodesIn: (Dictionary newFromPairs: { node. self buildCaseStmt: node in: aCodeGen})]. (#(caseOf: #caseOf:otherwise:) includes: node selector) ifTrue: [parent replaceNodesIn: (Dictionary newFromPairs: { node. self buildSwitchStmt: node parent: parent })]. (#(printf: f:printf:) includes: node selector) ifTrue: [| map | map := Dictionary new. node nodesDo: [:subNode| (subNode isConstant and: [subNode value isString and: [subNode value includes: $%]]) ifTrue: [map at: subNode put: subNode asPrintfFormatStringNode]. node replaceNodesIn: map]]]]]]! Item was added: + ----- Method: TSendNode>>selector: (in category 'accessing') ----- + selector: aSymbol + selector := aSymbol! Item was added: + ----- Method: VMClass class>>staticallyResolvePolymorphicSelector: (in category 'translation') ----- + staticallyResolvePolymorphicSelector: aSelectorSymbol + ^((self name select: [:ea| ea isUppercase]), '_', aSelectorSymbol) asSymbol!

1 0

Build completed: opensmalltalk-vm 1.0.1329
by AppVeyor 06 Jun '18

06 Jun '18

1 0

Errored: OpenSmalltalk/opensmalltalk-vm#1356 (Cog - 4fc727f)
by Travis CI 06 Jun '18

06 Jun '18

Build Update for OpenSmalltalk/opensmalltalk-vm ------------------------------------- Build: #1356 Status: Errored Duration: 12 mins and 3 secs Commit: 4fc727f (Cog) Author: Eliot Miranda Message: CogVM source as per VMMaker.oscog-eem.2402 BitBltPlugin The new primitiveDisplayString short cut has exposed an old bug: both loadBitBltDestForm & loadBitBltSourceForm sent byteSizeOf: to the form bits before checking if form bits isWordsOrBytes:. Also simplify loadHalftoneForm which comntained a superfluous (interpreterProxy isPointers: halftoneForm) not. View the changeset: https://github.com/OpenSmalltalk/opensmalltalk-vm/compare/a30c13238665...4f… View the full build log and details: https://travis-ci.org/OpenSmalltalk/opensmalltalk-vm/builds/388855938?utm_s… -- You can configure recipients for build notifications in your .travis.yml file. See https://docs.travis-ci.com/user/notifications This email was sent to vm-dev(a)lists.squeakfoundation.org (mailto:vm-dev@lists.squeakfoundation.org) unsubscribe from this list (http://clicks.travis-ci.com/track/unsub.php?u=14313403&id=d1f2653f2fd24213a…)

1 0

← Newer
1
2
3
4
5
6
7
8
9
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev June 2018