Quantcast

VM Maker: VMMaker.oscogSPC-eem.2119.mcz

Previous Topic Next Topic
 
classic Classic list List threaded Threaded
1 message Options
Reply | Threaded
Open this post in threaded view
|  
Report Content as Inappropriate

VM Maker: VMMaker.oscogSPC-eem.2119.mcz

commits-2
 
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscogSPC-eem.2119.mcz

==================== Summary ====================

Name: VMMaker.oscogSPC-eem.2119
Author: eem
Time: 2 February 2017, 5:12:51.57868 pm
UUID: 0dfec2b8-8348-4d9c-a393-7a2e8557f439
Ancestors: VMMaker.oscogSPC-eem.2118

SpurPlanningCompactor:
Remove reliance on noMobileObjectsAfter:.

Simplify the termination condition for copyAndUnmarkMobileObjects by introducing allOldSpaceEntitiesForCompactingFrom:to:do:.  Replace freeFrom:upTo:previousPin: with freeFrom:upTo:nextObject: cuz parsing the objects beyond the lastMobileObject always needs a pointer to an object in the sequence.

coaleseFrom: must take a start address, not an object.

unmarkObjectsAfterLastMobileObject must free unmarked objects.  updatePointersInObjectsOverflowingSavedFirstFieldsSpace must ignore unmarked objects.

Fix a regression with classAtIndex:; it used to be inlined but the extra phrase in the assert lifted it above the inlinign level (perhaps inlining should ignore asserts).

Make printOopsFrom:to: skip free space instead of printing an empty object every 16 bytes.

validRelocationPlanInPass: must be written just so to avoid an empty savedFirstFieldsSpace causing unsigned integer overflow.

Add a test for compacting a fully compacted heap.

Slang:
Don't localize globals that are used in only one funciton if they are only written to.  Such variables are typically for debugging (observation).

=============== Diff against VMMaker.oscogSPC-eem.2118 ===============

Item was changed:
  ----- Method: CCodeGenerator>>localizeGlobalVariables (in category 'utilities') -----
  localizeGlobalVariables
  | candidates elected localized |
 
  "find all globals used in only one method"
  candidates := globalVariableUsage select: [:e | e size = 1].
+ "Don't localize globals; nor those that are only assigned to; they're for debugging..."
+ (candidates keys select: [:k| (vmClass mustBeGlobal: k)
+ or: [(self methodNamed: (globalVariableUsage at: k) anyOne)
+ ifNil: [false]
+ ifNotNil: [:m| (m readsVariable: k) not]]]) do:
- (candidates keys select: [:k| vmClass mustBeGlobal: k]) do:
  [:k| candidates removeKey: k].
+
  elected := Set new.
  localized := Dictionary new. "for an ordered report"
  "move any suitable global to be local to the single method using it"
  candidates keysAndValuesDo:
  [:key :targets |
  targets do:
  [:name |
  (methods at: name ifAbsent: []) ifNotNil:
  [:procedure | | newDeclaration |
  (procedure isRealMethod
  and: [self shouldGenerateMethod: procedure]) ifTrue:
  [(localized at: name ifAbsentPut: [SortedCollection new]) add: key.
  elected add: (procedure locals add: key).
  newDeclaration := variableDeclarations at: key ifAbsent: ['sqInt ', key].
  (self initializerForInstVar: key inStartClass: procedure definingClass) ifNotNil:
  [:initializerNode|
  newDeclaration := String streamContents:
  [:s|
  s nextPutAll: newDeclaration; nextPutAll: ' = '.
  initializerNode emitCCodeOn: s level: 0 generator: self]].
  procedure declarationAt: key put: newDeclaration.
  variableDeclarations removeKey: key ifAbsent: []]]]].
  logger ifNotNil:
  [localized keys asSortedCollection do:
  [:name|
  (localized at: name) do:
  [:var|
  logger ensureCr; show: var, ' localised to ', name; cr]]].
  elected do: [:ea| (variables includes: ea) ifTrue: [self checkDeleteVariable: ea]].
  variables removeAllFoundIn: elected!

Item was removed:
- ----- Method: SpurMemoryManager>>allOldSpaceEntitiesForCompactingFrom:do: (in category 'object enumeration') -----
- allOldSpaceEntitiesForCompactingFrom: initialObject do: aBlock
- <inline: true>
- | prevObj prevPrevObj objOop nextObj |
- self assert: (self isOldObject: initialObject).
- prevPrevObj := prevObj := nil.
- objOop := initialObject.
- [self assert: objOop \\ self allocationUnit = 0.
- self oop: objOop isLessThan: endOfMemory] whileTrue:
- [self assert: (self long64At: objOop) ~= 0.
- nextObj := self objectAfter: objOop limit: endOfMemory.
- aBlock value: objOop value: nextObj.
- prevPrevObj := prevObj.
- prevObj := objOop.
- objOop := nextObj].
- self touch: prevPrevObj.
- self touch: prevObj!

Item was added:
+ ----- Method: SpurMemoryManager>>allOldSpaceEntitiesForCompactingFrom:to:do: (in category 'object enumeration') -----
+ allOldSpaceEntitiesForCompactingFrom: initialObject to: finalObject do: aBlock
+ <inline: true>
+ | limit prevObj prevPrevObj objOop nextObj |
+ self assert: (self isOldObject: initialObject).
+ self assert: (self oop: finalObject isLessThanOrEqualTo: endOfMemory).
+ prevPrevObj := prevObj := nil.
+ objOop := initialObject.
+ limit := (self oop: finalObject isLessThan: endOfMemory) ifTrue: [self addressAfter: finalObject] ifFalse: [endOfMemory].
+ [self assert: objOop \\ self allocationUnit = 0.
+ self oop: objOop isLessThan: limit] whileTrue:
+ [self assert: (self long64At: objOop) ~= 0.
+ nextObj := self objectAfter: objOop limit: endOfMemory.
+ aBlock value: objOop value: nextObj.
+ prevPrevObj := prevObj.
+ prevObj := objOop.
+ objOop := nextObj].
+ self touch: prevPrevObj.
+ self touch: prevObj!

Item was changed:
  ----- Method: SpurMemoryManager>>classAtIndex: (in category 'class table') -----
  classAtIndex: classIndex
  <api>
+ <inline: true>
  | classTablePage |
  self assert: (classIndex >= 0 and: [classIndex <= self tagMask or: [classIndex >= self arrayClassIndexPun and: [classIndex <= self classIndexMask]]]).
  classTablePage := self fetchPointer: classIndex >> self classTableMajorIndexShift
  ofObject: hiddenRootsObj.
  classTablePage = nilObj ifTrue:
  [^nil].
  ^self
  fetchPointer: (classIndex bitAnd: self classTableMinorIndexMask)
  ofObject: classTablePage!

Item was changed:
  ----- Method: SpurMemoryManager>>printOopsFrom:to: (in category 'debug printing') -----
  printOopsFrom: startAddress to: endAddress
  <api>
+ | oop limit firstNonEntity inEmptySpace lastNonEntity |
- | oop limit |
  oop := self objectBefore: startAddress.
  limit := endAddress asUnsignedIntegerPtr min: endOfMemory.
  oop := oop
  ifNil: [startAddress]
  ifNotNil: [(self objectAfter: oop) = startAddress
  ifTrue: [startAddress]
  ifFalse: [oop]].
+ inEmptySpace := false.
  [self oop: oop isLessThan: limit] whileTrue:
  [self printEntity: oop.
+ [oop := self objectAfter: oop.
+  (self long64At: oop) = 0] whileTrue:
+ [inEmptySpace ifFalse:
+ [inEmptySpace := true.
+ firstNonEntity := oop].
+ lastNonEntity := oop].
+ inEmptySpace ifTrue:
+ [inEmptySpace := false.
+ coInterpreter
+ print: 'skipped empty space from '; printHexPtrnp: firstNonEntity;
+ print:' to '; printHexPtrnp: lastNonEntity; cr.
+ oop := self objectStartingAt: oop]]!
- oop := self objectAfter: oop]!

Item was changed:
  ----- Method: SpurPlanningCompactor>>coalesceFrom: (in category 'private') -----
+ coalesceFrom: maybeStartOfFree
+ "manager printOopsFrom: maybeStartOfFree to: manager endOfMemory"
+ <var: 'maybeStartOfFree' type: #usqInt>
- coalesceFrom: maybeFirstFree
- "manager printOopsFrom: maybeFirstFree to: manager endOfMemory"
- <var: 'maybeFirstFree' type: #usqInt>
  | obj next |
  <var: 'obj' type: #usqInt>
  <var: 'next' type: #usqInt>
+ maybeStartOfFree >= manager endOfMemory ifTrue:
- maybeFirstFree >= manager endOfMemory ifTrue:
  [^self].
+ obj := manager objectStartingAt: maybeStartOfFree.
- obj := maybeFirstFree.
  [next := manager oldSpaceObjectAfter: obj.
  next < manager endOfMemory] whileTrue:
  [((manager isFreeObject: obj) and: [manager isFreeObject: next])
  ifTrue:
+ [manager unlinkFreeChunk: obj.
+ manager unlinkFreeChunk: next.
+ obj := manager freeChunkWithBytes: (manager bytesInObject: obj) + (manager bytesInObject: next) at: (manager startOfObject: obj)]
- [manager
- unlinkFreeChunk: obj;
- unlinkFreeChunk: next;
- freeChunkWithBytes: (manager bytesInObject: obj) + (manager bytesInObject: next) at: (manager startOfObject: obj)]
  ifFalse:
  [obj := next]]!

Item was changed:
  ----- Method: SpurPlanningCompactor>>compact (in category 'compaction - api') -----
  compact
  "Sweep all of old space, sliding unpinned marked objects down over free and unmarked objects.
  Let the segmentManager mark which segments contain pinned objects via notePinned:."
  | onePass firstPass |
  <inline: #never> "for profiling"
  self initializeScanCheckingForFullyCompactedHeap ifTrue:
  [^self unmarkObjectsInFullyCompactedHeap].
  self initializeCompaction.
  firstPass := true.
  [onePass := self planCompactSavingForwarders.
  self assert: (self validRelocationPlanInPass: onePass) = 0.
  objectAfterLastMobileObject := manager oldSpaceObjectAfter: lastMobileObject.
  self updatePointers.
  self copyAndUnmark: firstPass.
+ "Would like to check here, but can't if multi-pass."
+ false ifTrue: [manager checkFreeSpace: GCModeFull].
- manager checkFreeSpace: GCModeFull.
  onePass or: [biasForGC]] whileFalse:
  [firstPass := false.
  self reinitializeScanFrom: objectAfterLastMobileObject;
  updateSavedFirstFieldsSpaceIfNecessary].
+ manager checkFreeSpace: GCModeFull.
  self endCompaction!

Item was changed:
  ----- Method: SpurPlanningCompactor>>copyAndUnmark: (in category 'compaction') -----
  copyAndUnmark: firstPass
  "Sweep the heap, unmarking all objects and moving mobile objects to their correct positions,
  restoring their savedFirstFields."
  <inline: #never>
  | onePass |
  self logPhase: 'copying and unmarking...'.
  firstPass ifTrue:
  [self unmarkInitialImmobileObjects].
  "If savedFirstFieldsSpace is empty there is nothing to move, and no second pass."
  savedFirstFieldsSpace top < savedFirstFieldsSpace start ifTrue:
+ [self assert: ((self oop: firstMobileObject isGreaterThanOrEqualTo: manager endOfMemory)
+ or: [lastMobileObject < firstMobileObject]).
- [self assert: (self oop: firstMobileObject isGreaterThanOrEqualTo: manager endOfMemory).
  ^self].
  onePass := self copyAndUnmarkMobileObjects.
  (onePass not and: [biasForGC]) ifTrue: "only ever one pass if biasForGC is true."
  [self unmarkObjectsAfterLastMobileObject]!

Item was changed:
  ----- Method: SpurPlanningCompactor>>copyAndUnmarkMobileObjects (in category 'compaction') -----
  copyAndUnmarkMobileObjects
  "Sweep the mobile portion of the heap, moving objects to their eventual locations, and clearing their marked bits.
  Remember to update the savedFirstFields of pointer objects, as these have been forwarded.
  Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed).
 
  The enumerations in planCompactSavingForwarders, updatePointersInMobileObjects and copyAndUnmarkMobileObjects
  match.  We could implement them as a single enumeration method taking several block arguments, but arguably that
  would make understanding an already tricky algorithm more difficult.  Instead we tolerate the duplication and encourage
  the reader to diff the three methods to see where they diverge (e.g. via Cmd-shift-C)."
  <inline: #never>
  | toFinger top previousPin |
  <var: 'o' type: #usqInt>
  <var: 'top' type: #usqInt>
  <var: 'toFinger' type: #usqInt>
  <var: 'previousPin' type: #usqInt>
  self deny: (manager isMarked: firstFreeObject).
  toFinger := manager startOfObject: firstFreeObject.
  top := savedFirstFieldsSpace start.
+ manager allOldSpaceEntitiesForCompactingFrom: firstFreeObject to: lastMobileObject do:
+ [:o :n|
- manager allOldSpaceEntitiesForCompactingFrom: firstFreeObject do:
- [:o :n| | done |
  self check: o.
  self assert: (previousPin
  ifNil: [toFinger <= (manager startOfObject: o)]
  ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= (manager startOfObject: previousPin)]]).
  self assert: (savedFirstFieldsSpaceNotInOldSpace or: [toFinger < top]).
  (manager isMarked: o) ifTrue:
+ [(manager isPinned: o)
- [o > lastMobileObject ifTrue:
- ["If this is onePass (noMobileObjectsFrom: objectAfterLastMobileObject) free up to end of memory.
-  A bug in this approach is that it may create two free objects at the end of memory.  Work around
-  this with the coalesce pass below.
-  If this is multi-pass, free up to startOfObject: objectAfterLastMobileObject."
- | maybeStartOfFree |
- self assert: (self oop: o isGreaterThanOrEqualTo: objectAfterLastMobileObject).
- self freeFrom: toFinger upTo: (manager startOfObject: objectAfterLastMobileObject) previousPin: previousPin.
- maybeStartOfFree := toFinger < (manager startOfObject: objectAfterLastMobileObject)
- ifTrue: [manager objectStartingAt: toFinger]
- ifFalse: [objectAfterLastMobileObject].
- done := self noMobileObjectsFrom: objectAfterLastMobileObject.
- done ifTrue:
- [toFinger := manager startOfObject: objectAfterLastMobileObject.
- previousPin := (manager isPinned: objectAfterLastMobileObject) ifTrue: [objectAfterLastMobileObject].
- self freeFrom: toFinger upTo: manager endOfMemory previousPin: previousPin.
- self coalesceFrom: maybeStartOfFree].
- ^done].
- (manager isPinned: o)
  ifTrue:
  [previousPin ifNil:
  [previousPin := o]]
  ifFalse:
  [| availableSpace bytes |
  bytes := manager bytesInObject: o.
  [previousPin notNil
   and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
  bytes ~= availableSpace
  and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue:
  ["The object does not fit in the space between toFinger and previousPin.
    Move toFinger up to point at the first unmarked or mobile object after
    previousPin, or, if previousPin is contiguous with o, to the start of this
    object.  Update previousPin to be the next pinned object above toFInger
    and below this object, or nil if no such pinned object exists.
    Any unfillable gaps between adjacent pinned objects will be freed."
  availableSpace > 0 ifTrue:
  [manager addFreeChunkWithBytes: availableSpace at: toFinger].
  [self assert: ((manager isMarked: previousPin) and: [manager isPinned: previousPin]).
   self unmarkPinned: previousPin.
   toFinger := manager addressAfter: previousPin.
   previousPin := manager objectStartingAt: toFinger.
   (manager isMarked: previousPin)
    and: [(manager isPinned: previousPin)
    and: [previousPin < o]]]
  whileTrue.
  "Now previousPin is either equal to o or mobile.
   Move it to the next pinned object below o"
  [previousPin >= o
   or: [(manager isMarked: previousPin)
   and: [manager isPinned: previousPin]]] whileFalse:
  [previousPin := manager oldSpaceObjectAfter: previousPin].
  previousPin >= o ifTrue:
  [previousPin := nil]].
  self copyAndUnmarkObject: o to: toFinger bytes: bytes firstField: (manager longAt: top).
  toFinger := toFinger + bytes.
  (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
  [self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop).
+ self assert: n = objectAfterLastMobileObject.
+ self freeFrom: toFinger upTo: (manager startOfObject: n) nextObject: (previousPin ifNil: [n]).
+ ^false]]]].
+ self freeFrom: toFinger upTo: manager endOfMemory nextObject: (previousPin ifNil: [objectAfterLastMobileObject]).
+ self coalesceFrom: toFinger.
- done := self noMobileObjectsFrom: n.
- done
- ifTrue: [self freeAllUnpinnedObjectsFromObject: (previousPin ifNil: [n]) toFinger: toFinger]
- ifFalse: [self freeFrom: toFinger upTo: (manager startOfObject: n) previousPin: previousPin].
- ^done]]]].
- self freeFrom: toFinger upTo: manager endOfMemory previousPin: previousPin.
- self coalesceFrom: (manager objectStartingAt: toFinger).
  ^true!

Item was added:
+ ----- Method: SpurPlanningCompactor>>freeFrom:upTo:nextObject: (in category 'private') -----
+ freeFrom: initialToFinger upTo: limit nextObject: nextObject
+ "Free from toFinger up to limit, dealing with possible intervening pinned objects."
+ <inline: false>
+ <var: 'limit' type: #usqInt>
+ <var: 'initialToFinger' type: #usqInt>
+ | toFinger obj objStart |
+ <var: 'objStart' type: #usqInt>
+ <var: 'toFinger' type: #usqInt>
+ self cCode: [] inSmalltalk:
+ [coInterpreter cr; cr; print: 'freeing at '; printHexnp: initialToFinger; print: ' up to '; printHexnp: limit; cr].
+ toFinger := initialToFinger.
+ objStart := manager startOfObject: nextObject.
+ toFinger < objStart ifTrue:
+ [manager addFreeChunkWithBytes: objStart - toFinger at: toFinger].
+ toFinger := objStart.
+ [objStart < limit] whileTrue:
+ [obj := manager objectStartingAt: objStart.
+ ((manager isMarked: obj) and: [manager isPinned: obj])
+ ifTrue:
+ [self unmarkPinned: obj.
+ toFinger < objStart ifTrue:
+ [manager addFreeChunkWithBytes: objStart - toFinger at: toFinger].
+ toFinger := objStart := manager addressAfter: obj]
+ ifFalse:
+ [objStart := manager addressAfter: obj]].
+ limit > toFinger ifTrue:
+ [manager addFreeChunkWithBytes: limit - toFinger at: toFinger]!

Item was removed:
- ----- Method: SpurPlanningCompactor>>freeFrom:upTo:previousPin: (in category 'private') -----
- freeFrom: toFinger upTo: limit previousPin: previousPinOrNil
- "Free from toFinger up to limit, dealing with a possible intervening run of pinned objects starting at previousPinOrNil."
- <inline: false>
- <var: 'limit' type: #usqInt>
- <var: 'toFinger' type: #usqInt>
- <var: 'previousPinOrNil' type: #usqInt>
- | effectiveToFinger pin nextUnpinned start seg |
- <var: 'nextUnpinned' type: #usqInt>
- <var: #seg type: #'SpurSegmentInfo *'>
- self cCode: [] inSmalltalk:
- [coInterpreter cr; cr; print: 'freeing at '; printHexnp: toFinger; print: ' up to '; printHexnp: limit; print: ' pin '; printHexnp: previousPinOrNil; cr].
- effectiveToFinger := toFinger.
- pin := previousPinOrNil.
- "If the range toFinger to limit spans segments but there is no pin (as when freeing to the end of memory)
- segment boundaries must still be observed.  So in this case use the nearest bridge above toFinger as the pin."
- pin ifNil:
- [seg := manager segmentManager segmentContainingObj: toFinger.
- self deny: seg isNil.
- seg segLimit < limit ifTrue:
- [pin := manager segmentManager bridgeFor: seg]].
- [pin notNil and: [pin < limit]] whileTrue:
- [(start := manager startOfObject: pin) > toFinger ifTrue:
- [manager addFreeChunkWithBytes: start - effectiveToFinger at: effectiveToFinger].
- nextUnpinned := self unmarkPinnedObjectsAndFindFirstUnpinnedOrFreeEntityFollowing: pin.
- nextUnpinned >= limit ifTrue:
- [^self].
- effectiveToFinger := manager startOfObject: nextUnpinned.
- pin := self findNextMarkedPinnedAfter: nextUnpinned].
- limit > effectiveToFinger ifTrue:
- [manager addFreeChunkWithBytes: limit - effectiveToFinger at: effectiveToFinger]!

Item was removed:
- ----- Method: SpurPlanningCompactor>>noMobileObjectsAfter: (in category 'private') -----
- noMobileObjectsAfter: mobileObj
- self assert: ((manager isMarked: mobileObj) and: [(manager isPinned: mobileObj) not]).
- manager allOldSpaceEntitiesFrom: mobileObj do:
- [:o|
- ((manager isMarked: o) and: [(manager isPinned: o) not]) ifTrue:
- [^false]].
- ^true!

Item was removed:
- ----- Method: SpurPlanningCompactor>>noMobileObjectsFrom: (in category 'private') -----
- noMobileObjectsFrom: mobileObj
- <inline: false>
- manager allOldSpaceEntitiesFrom: mobileObj do:
- [:o|
- ((manager isMarked: o) and: [(manager isPinned: o) not]) ifTrue:
- [^false]].
- ^true!

Item was changed:
  ----- Method: SpurPlanningCompactor>>planCompactSavingForwarders (in category 'compaction') -----
  planCompactSavingForwarders
  "Sweep the heap from firstFreeObject forwarding marked objects to where they
  can be moved to, saving their forwarding pointer in savedFirstFieldsSpace.
  Continue until either the end of the heap is reached or savedFirstFieldsSpace is full.
  Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed).
 
  The enumerations in planCompactSavingForwarders, updatePointersInMobileObjects and copyAndUnmarkMobileObjects
  match.  We could implement them as a single enumeration method taking several block arguments, but arguably that
  would make understanding an already tricky algorithm more difficult.  Instead we tolerate the duplication and encourage
  the reader to diff the three methods to see where they diverge (e.g. via Cmd-shift-C)."
  <inline: #never>
  | toFinger top previousPin |
  <var: 'o' type: #usqInt>
  <var: 'top' type: #usqInt>
  <var: 'toFinger' type: #usqInt>
  <var: 'previousPin' type: #usqInt>
  savedFirstFieldsSpace top < savedFirstFieldsSpace start ifTrue:
  [self logPhase: 'planning...'].
  self deny: (manager isMarked: firstFreeObject).
  toFinger := manager startOfObject: firstFreeObject.
  top := savedFirstFieldsSpace start.
  manager allOldSpaceEntitiesFrom: firstFreeObject do:
  [:o|
  self check: o.
  self assert: (previousPin
  ifNil: [toFinger <= (manager startOfObject: o)]
  ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= (manager startOfObject: previousPin)]]).
  self assert: (savedFirstFieldsSpaceNotInOldSpace or: [toFinger < top]).
  (manager isMarked: o) ifTrue:
  [(manager isPinned: o)
  ifTrue:
  [previousPin ifNil:
  [previousPin := o]]
  ifFalse:
  [| availableSpace bytes |
  bytes := manager bytesInObject: o.
  [previousPin notNil
   and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
  bytes ~= availableSpace
  and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue:
  ["The object does not fit in the space between toFinger and previousPin.
    Move toFinger up to point at the first unmarked or mobile object after
    previousPin, or, if previousPin is contiguous with o, to the start of this
    object.  Update previousPin to be the next pinned object above toFInger
    and below this object, or nil if no such pinned object exists.
    Any unfillable gaps between adjacent pinned objects will be freed."
  [toFinger := manager addressAfter: previousPin.
   previousPin := manager objectStartingAt: toFinger.
   (manager isMarked: previousPin)
    and: [(manager isPinned: previousPin)
    and: [previousPin < o]]]
  whileTrue.
  "Now previousPin is either equal to o or mobile.
   Move it to the next pinned object below o"
  [previousPin >= o
   or: [(manager isMarked: previousPin)
   and: [manager isPinned: previousPin]]] whileFalse:
  [previousPin := manager oldSpaceObjectAfter: previousPin].
  previousPin >= o ifTrue:
  [previousPin := nil]].
  self forwardMobileObject: o to: toFinger savedFirstFieldPtr: top.
  toFinger := toFinger + bytes.
  (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
  [savedFirstFieldsSpace top: top - manager bytesPerOop.
+ ^false]]]].
- ^self noMobileObjectsAfter: o]]]].
  savedFirstFieldsSpace top: top - manager bytesPerOop.
  ^true!

Item was changed:
  ----- Method: SpurPlanningCompactor>>unmarkObjectsAfterLastMobileObject (in category 'compaction') -----
  unmarkObjectsAfterLastMobileObject
+ "Sweep the final immobile heap, freeing and coalescing unmarked and free objects,
+ and unmarking all marked objects up to the end of memory."
+ | startOfFree freeBytes |
+ freeBytes := 0.
+ manager allOldSpaceEntitiesFrom: objectAfterLastMobileObject do:
- "Sweep the final immobile heap, unmarking all objects up to the end of memory."
- manager allOldSpaceObjectsFrom: objectAfterLastMobileObject do:
  [:o|
  self check: o.
+ (manager isMarked: o)
+ ifFalse:
+ [startOfFree ifNil: [startOfFree := manager startOfObject: o].
+ freeBytes := freeBytes + manager bytesInObject: o]
+ ifTrue:
+ [startOfFree ifNotNil:
+ [manager addFreeChunkWithBytes: freeBytes at: startOfFree.
+ startOfFree := nil.
+ freeBytes := 0].
+ (manager isSegmentBridge: o) ifFalse:
+ [manager setIsMarkedOf: o to: false]]]!
- manager setIsMarkedOf: o to: false]!

Item was changed:
  ----- Method: SpurPlanningCompactor>>updatePointersInMobileObjects (in category 'compaction') -----
  updatePointersInMobileObjects
  "Sweep the mobile portion of the heap, updating all references to objects to their eventual locations.
  Remember to update the savedFirstFields of pointer objects, as these have been forwarded.
  Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed).
 
  The enumerations in planCompactSavingForwarders, updatePointersInMobileObjects and copyAndUnmarkMobileObjects
  match.  We could implement them as a single enumeration method taking several block arguments, but arguably that
  would make understanding an already tricky algorithm more difficult.  Instead we tolerate the duplication and encourage
  the reader to diff the three methods to see where they diverge (e.g. via Cmd-shift-C)."
  | toFinger top previousPin |
  <var: 'o' type: #usqInt>
  <var: 'top' type: #usqInt>
  <var: 'toFinger' type: #usqInt>
  <var: 'previousPin' type: #usqInt>
  self deny: (manager isMarked: firstFreeObject).
  toFinger := manager startOfObject: firstFreeObject.
  top := savedFirstFieldsSpace start.
  manager allOldSpaceEntitiesFrom: firstFreeObject do:
  [:o|
  self check: o.
  self assert: (previousPin
  ifNil: [toFinger <= (manager startOfObject: o)]
  ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= (manager startOfObject: previousPin)]]).
  (manager isMarked: o) ifTrue:
  [(manager isPinned: o)
  ifTrue:
  [previousPin ifNil:
  [previousPin := o].
  self updatePointersIn: o]
  ifFalse:
  [| availableSpace bytes |
  bytes := manager bytesInObject: o.
  [previousPin notNil
   and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
  bytes ~= availableSpace
  and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue:
  ["The object does not fit in the space between toFinger and previousPin.
    Move toFinger up to point at the first unmarked or mobile object after
    previousPin, or, if previousPin is contiguous with o, to the start of this
    object.  Update previousPin to be the next pinned object above toFInger
    and below this object, or nil if no such pinned object exists.
    Any unfillable gaps between adjacent pinned objects will be freed."
  [toFinger := manager addressAfter: previousPin.
   previousPin := manager objectStartingAt: toFinger.
   (manager isMarked: previousPin)
    and: [(manager isPinned: previousPin)
    and: [previousPin < o]]]
  whileTrue.
  "Now previousPin is either equal to o or mobile.
   Move it to the next pinned object below o"
  [previousPin >= o
   or: [(manager isMarked: previousPin)
   and: [manager isPinned: previousPin]]] whileFalse:
  [previousPin := manager oldSpaceObjectAfter: previousPin].
  previousPin >= o ifTrue:
  [previousPin := nil]].
  self updatePointersIn: o savedFirstFieldPointer: top.
  toFinger := toFinger + bytes.
  (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
  [self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop).
+ ^false]]]].
- ^self noMobileObjectsFrom: o]]]].
  self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop).
  ^true!

Item was changed:
  ----- Method: SpurPlanningCompactor>>updatePointersInObjectsOverflowingSavedFirstFieldsSpace (in category 'compaction') -----
  updatePointersInObjectsOverflowingSavedFirstFieldsSpace
  "Sweep the final immobile heap, is any (those objects with no room in savedFirstFieldsSpace
  in the current pass) updating all references to mobile objects to their eventual locations."
  manager allOldSpaceObjectsFrom: objectAfterLastMobileObject do:
  [:o|
  self check: o.
+ (manager isMarked: o) ifTrue:
+ [self updatePointersIn: o]]!
- self assert: (manager isMarked: o).
- self updatePointersIn: o]!

Item was changed:
  ----- Method: SpurPlanningCompactor>>validRelocationPlanInPass: (in category 'private') -----
  validRelocationPlanInPass: onePass
  "Answer 0 if all the mobile objects from firstMobileObject to lastMobileObject
  have sane forwarding addresses, and that savedFirstFieldsSpace is of
  matching capacity.  Otherwise answer an error code identifying the anomaly."
  | nMobiles toFinger |
  <var: 'toFinger' type: #usqInt>
  <var: 'destination' type: #usqInt>
  nMobiles := 0.
  toFinger := mobileStart.
  anomaly := nil.
  manager allOldSpaceEntitiesFrom: firstMobileObject do:
  [:o| | destination |
  self check: o.
  (manager isMarked: o) ifTrue:
  [(manager isPinned: o) ifFalse:
  [nMobiles := nMobiles + 1.
  destination := manager fetchPointer: 0 ofObject: o.
  destination >= toFinger ifFalse:
  [anomaly := o. ^1].
  toFinger := toFinger + (manager bytesInObject: o).
  (self oop: o isGreaterThan: lastMobileObject) ifTrue:
  [anomaly := o. ^2].
  o = lastMobileObject ifTrue:
+ [^savedFirstFieldsSpace top + manager bytesPerOop - savedFirstFieldsSpace start / manager bytesPerOop
- [^savedFirstFieldsSpace top - savedFirstFieldsSpace start / manager bytesPerOop + 1
    = nMobiles
  ifTrue: [0]
  ifFalse: [3]]]]].
+ "N.B. written this way so that if there are no mobiles the expression evaluates to 0 in Smalltalk /and/ in C unsigned arithmetic."
+ ^savedFirstFieldsSpace top + manager bytesPerOop - savedFirstFieldsSpace start / manager bytesPerOop
- ^savedFirstFieldsSpace top - savedFirstFieldsSpace start / manager bytesPerOop + 1
   = nMobiles
  ifTrue: [0]
  ifFalse: [4]!

Item was added:
+ ----- Method: SpurPlanningCompactorTests>>testCompactedHeap (in category 'tests') -----
+ testCompactedHeap
+ "First test for valid compactibility of an already compacted heap via fullGC"
+ | freeSpace om |
+ om := self initializedVM objectMemory.
+ freeSpace := om bytesLeftInOldSpace.
+ om fullGC.
+ self assert: freeSpace equals: om bytesLeftInOldSpace!

Item was added:
+ ----- Method: TInlineNode>>nodesDo:parent: (in category 'enumerating') -----
+ nodesDo: aBlock parent: parent
+ "Apply aBlock to all nodes in the receiver with each node's parent.
+ N.B. This is assumed to be bottom-up, leaves first."
+ method parseTree nodesDo: aBlock parent: self.
+ aBlock value: self value: parent!

Item was added:
+ ----- Method: TMethod>>readsVariable: (in category 'accessing') -----
+ readsVariable: variableName
+ "Answer if the receiver reads the variable (i.e. ignore assignments to the variable)."
+ parseTree nodesWithParentsDo:
+ [:node :parent|
+ (node isVariable
+  and: [node name = variableName]) ifTrue:
+ [(parent notNil
+  and: [parent isAssignment
+  and: [node == parent variable]]) ifFalse:
+ [^true]]].
+ ^false!

Loading...