[Vm-dev] VM Maker: VMMaker.oscog-eem.2115.mcz
commits at source.squeak.org
commits at source.squeak.org
Fri Jan 27 18:51:04 UTC 2017
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2115.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.2115
Author: eem
Time: 27 January 2017, 10:49:54.261323 am
UUID: ddcc6891-86da-481d-bed3-56e7a842d41f
Ancestors: VMMaker.oscog-cb.2113, VMMaker.oscogSPC-eem.2114
Merge
=============== Diff against VMMaker.oscog-cb.2113 ===============
Item was added:
+ ----- Method: CogObjectRepresentationForSpur>>checkValidDerivedObjectReference: (in category 'debug support') -----
+ checkValidDerivedObjectReference: bodyAddress
+ ^(objectMemory heapMapAtWord: (self pointerForOop: bodyAddress - objectMemory baseHeaderSize)) ~= 0!
Item was added:
+ ----- Method: CogObjectRepresentationForSpur>>couldBeDerivedObject: (in category 'garbage collection') -----
+ couldBeDerivedObject: bodyAddress
+ ^self oop: bodyAddress - objectMemory baseHeaderSize isGreaterThanOrEqualTo: objectMemory startOfMemory!
Item was changed:
----- Method: CogObjectRepresentationForSpur>>markIfIRC: (in category 'newspeak support') -----
markIfIRC: maybeIRCs
"If maybeIRCs (from some cogMehtod's nextMethodOrIRCs) is in old space it is
a pointer to the first field of a pinned object in old space holding the implicit
receiver caches for a method. If so, map it back to an oop and mark it."
<var: #maybeIRCs type: #usqInt>
<option: #NewspeakVM>
+ <inline: true>
(self oop: maybeIRCs isGreaterThan: objectMemory nilObject) ifTrue:
[objectMemory markAndTrace: maybeIRCs - objectMemory baseHeaderSize]!
Item was changed:
----- Method: Cogit>>allMachineCodeObjectReferencesValid (in category 'garbage collection') -----
allMachineCodeObjectReferencesValid
"Check that all methods have valid selectors, and that all linked sends are to valid targets and have valid cache tags"
| ok cogMethod |
<var: #cogMethod type: #'CogMethod *'>
ok := true.
cogMethod := self cCoerceSimple: methodZoneBase to: #'CogMethod *'.
[cogMethod < methodZone limitZony] whileTrue:
[cogMethod cmType ~= CMFree ifTrue:
[(self asserta: (objectRepresentation checkValidOopReference: cogMethod selector)) ifFalse:
[ok := false].
(self asserta: (self cogMethodDoesntLookKosher: cogMethod) = 0) ifFalse:
[ok := false]].
(cogMethod cmType = CMMethod
or: [cogMethod cmType = CMOpenPIC]) ifTrue:
[(self asserta: ((self mapFor: cogMethod
performUntil: #checkIfValidOopRefAndTarget:pc:cogMethod:
arg: cogMethod asInteger) = 0)) ifFalse:
[ok := false]].
+ (cogMethod cmType = CMMethod
+ and: [(NewspeakVM or: [SistaVM])
+ and: [objectRepresentation canPinObjects]]) ifTrue:
+ [(SistaVM and: [cogMethod counters ~= 0]) ifTrue:
+ [(self asserta: (objectRepresentation checkValidDerivedObjectReference: cogMethod counters)) ifFalse:
+ [ok := false]].
+ (NewspeakVM and: [cogMethod nextMethodOrIRCs ~= 0]) ifTrue:
+ [(self asserta: (objectRepresentation checkValidDerivedObjectReference: cogMethod nextMethodOrIRCs)) ifFalse:
+ [ok := false]]].
cogMethod cmType = CMClosedPIC ifTrue:
[(self asserta: (self noTargetsFreeInClosedPIC: cogMethod)) ifFalse:
[ok := false]].
cogMethod := methodZone methodAfter: cogMethod].
^ok!
Item was changed:
----- Method: Cogit>>cogMethodDoesntLookKosher: (in category 'debugging') -----
cogMethodDoesntLookKosher: cogMethod
"Check that the header fields onf a non-free method are consistent with
the type. Answer 0 if it is ok, otherwise answer a code for the error."
<api>
<inline: false>
<var: #cogMethod type: #'CogMethod *'>
((cogMethod blockSize bitAnd: objectMemory wordSize - 1) ~= 0
or: [cogMethod blockSize < (self sizeof: CogMethod)
or: [cogMethod blockSize >= 32768]]) ifTrue:
[^1].
cogMethod cmType = CMFree ifTrue: [^2].
cogMethod cmType = CMMethod ifTrue:
[(objectMemory isIntegerObject: cogMethod methodHeader) ifFalse:
[^11].
(objectRepresentation couldBeObject: cogMethod methodObject) ifFalse:
[^12].
(cogMethod stackCheckOffset > 0
+ and: [cogMethod stackCheckOffset < cmNoCheckEntryOffset]) ifTrue:
- and: [cogMethod stackCheckOffset < cmNoCheckEntryOffset]) ifTrue:
[^13].
+ (SistaVM
+ and: [objectRepresentation canPinObjects
+ and: [cogMethod counters ~= 0]]) ifTrue:
+ [(objectRepresentation couldBeDerivedObject: cogMethod counters) ifFalse:
+ [^14]].
+ (NewspeakVM
+ and: [objectRepresentation canPinObjects
+ and: [cogMethod nextMethodOrIRCs ~= 0]]) ifTrue:
+ [(objectRepresentation couldBeDerivedObject: cogMethod nextMethodOrIRCs) ifFalse:
+ [^15]].
^0].
cogMethod cmType = CMOpenPIC ifTrue:
[cogMethod blockSize ~= openPICSize ifTrue:
[^21].
cogMethod methodHeader ~= 0 ifTrue:
[^22].
"Check the nextOpenPIC link unless we're compacting"
cogMethod objectHeader >= 0 ifTrue:
[(cogMethod methodObject ~= 0
and: [cogMethod methodObject < methodZoneBase
or: [cogMethod methodObject > (methodZone freeStart - openPICSize)
or: [(cogMethod methodObject bitAnd: objectMemory wordSize - 1) ~= 0
or: [(self cCoerceSimple: cogMethod methodObject
to: #'CogMethod *') cmType ~= CMOpenPIC]]]]) ifTrue:
[^23]].
cogMethod stackCheckOffset ~= 0 ifTrue:
[^24].
^0].
cogMethod cmType = CMClosedPIC ifTrue:
[cogMethod blockSize ~= closedPICSize ifTrue:
[^31].
(cogMethod cPICNumCases between: 1 and: MaxCPICCases) ifFalse:
[^32].
cogMethod methodHeader ~= 0 ifTrue:
[^33].
cogMethod methodObject ~= 0 ifTrue:
[^34].
^0].
^9!
Item was changed:
----- Method: SpurMemoryManager>>adjustAllOopsBy: (in category 'snapshot') -----
adjustAllOopsBy: bytesToShift
"Adjust all oop references by the given number of bytes. This is
done just after reading in an image when the new base address
of the object heap is different from the base address in the image,
or when loading multiple segments that have been coalesced. Also
set bits in the classTableBitmap corresponding to used classes."
| obj classIndex |
self assert: self newSpaceIsEmpty.
self countNumClassPagesPreSwizzle: bytesToShift.
(bytesToShift ~= 0
or: [segmentManager numSegments > 1]) ifTrue:
[obj := self objectStartingAt: oldSpaceStart.
[self oop: obj isLessThan: freeOldSpaceStart] whileTrue:
[classIndex := self classIndexOf: obj.
classIndex >= self isForwardedObjectClassIndexPun
ifTrue:
[self swizzleFieldsOfObject: obj]
ifFalse:
[classIndex = self isFreeObjectClassIndexPun ifTrue:
[self swizzleFieldsOfFreeChunk: obj]].
+ obj := self objectAfter: obj limit: endOfMemory]]!
- obj := self objectAfter: obj]]!
Item was changed:
----- Method: SpurMemoryManager>>freeListsObj (in category 'free space') -----
freeListsObj
+ self assert: (self firstIndexableField: (self oldSpaceObjectAfter: trueObj)) = freeLists.
+ ^self oldSpaceObjectAfter: trueObj!
- self assert: (self firstIndexableField: (self objectAfter: trueObj)) = freeLists.
- ^self objectAfter: trueObj!
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).
- self assert: falseObj = (self objectAfter: nilObj).
- self assert: trueObj = (self objectAfter: falseObj).
- freeListObj := self objectAfter: trueObj.
- self setHiddenRootsObj: (self objectAfter: 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 computeFreeSpacePostSwizzle.
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>>mem:cp:y: (in category 'simulation') -----
mem: destAddress cp: sourceAddress y: bytes
+ "For SpurGenerationScavenger>>copyToFutureSpace:bytes:. N.B. If ranges overlap, must use memmove."
- "For SpurGenerationScavenger>>copyToFutureSpace:bytes:"
<doNotGenerate>
+ self deny: ((destAddress <= sourceAddress and: [destAddress + bytes > sourceAddress])
+ or: [sourceAddress <= destAddress and: [sourceAddress + bytes > destAddress]]).
^self mem: destAddress mo: sourceAddress ve: bytes!
Item was added:
+ ----- Method: SpurMemoryManager>>oldSpaceObjectAfter: (in category 'object enumeration') -----
+ oldSpaceObjectAfter: objOop
+ <api>
+ "Object parsing.
+ 1. all objects have at least a word following the header, for a forwarding pointer.
+ 2. objects with an overflow size have a preceeing word with a saturated slotSize. If the word following
+ an object doesn't have a saturated size field it must be a single-header object. If the word following
+ does have a saturated slotSize it must be the overflow size word."
+ <inline: false>
+ ^self objectAfter: objOop limit: endOfMemory!
Item was added:
+ ----- Method: SpurMemoryManager>>printOopsSuchThat: (in category 'debug printing') -----
+ printOopsSuchThat: function
+ <api>
+ <var: #function declareC: 'sqInt (*function)(sqInt)'>
+ self allHeapEntitiesDo:
+ [:o|
+ (self perform: function with: o) ifTrue:
+ [self printEntity: o]]!
Item was changed:
----- Method: SpurMemoryManager>>startOfObject: (in category 'object enumeration') -----
startOfObject: objOop
"Answer the start of objOop, which is either the address of the overflow
size word, or objOop itself, depending on the size of the object. This may
be applied to any kind of object, normal, forwarders or free chunks."
+ <returnTypeC: #usqInt>
^(self hasOverflowHeader: objOop)
ifTrue: [objOop - self baseHeaderSize]
ifFalse: [objOop]!
Item was changed:
----- Method: SpurMemoryManager>>startOfObject:given: (in category 'object enumeration') -----
startOfObject: objOop given: rawNumSlots
"Answer the start of objOop, which is either the address of the overflow
size word, or objOop itself, depending on the size of the object. This may
be applied to any kind of object, normal, forwarders or free chunks."
+ <returnTypeC: #usqInt>
^(self objectWithRawSlotsHasOverflowHeader: rawNumSlots)
ifTrue: [objOop - self baseHeaderSize]
ifFalse: [objOop]!
Item was changed:
CogClass subclass: #SpurPlanningCompactor
+ instanceVariableNames: 'manager scavenger coInterpreter biasForGC firstFreeObject mobileStart firstMobileObject lastMobileObject savedFirstFieldsSpace savedFirstFieldsSpaceNotInOldSpace firstFieldOfRememberedSet interestingObj anomaly objectAfterLastMobileObject relocationMap'
- instanceVariableNames: 'manager scavenger coInterpreter biasForGC firstFreeObject mobileStart firstMobileObject lastMobileObject savedFirstFieldsSpace savedFirstFieldsSpaceNotInOldSpace firstFieldOfRememberedSet interestingObj anomaly objectAfterLastMobileObject'
classVariableNames: ''
poolDictionaries: 'SpurMemoryManagementConstants VMBasicConstants VMBytecodeConstants VMSpurObjectRepresentationConstants'
category: 'VMMaker-SpurMemoryManager'!
!SpurPlanningCompactor commentStamp: 'eem 12/23/2016 17:50' prior: 0!
SpurPlanningCompactor implements the classic planning compaction algorithm for Spur. It makes at least three passes through the heap. The first pass plans where live movable objects will go, copying their forwarding field to the next slot in savedFirstFieldsSpace, and setting their forwarding pointer to point to their eventual location. The second pass updates all pointers in live pointer objects to point to objects' final destinations. The third pass moves objects to their final positions, unmarking objects as it does so. If the forwarding fields of live objects in the to-be-moved portion of the entire heap won't fit in savedFirstFieldsSpace, then additional passes are made until the entire heap has been compacted.
Instance Variables
biasForGC <Boolean>
coInterpreter: <StackInterpreter>
firstFieldOfRememberedSet <Oop>
firstFreeObject <Oop>
firstMobileObject <Oop>
lastMobileObject <Oop>
manager: <SpurMemoryManager>
savedFirstFieldsSpace <SpurContiguousObjStack>
savedFirstFieldsSpaceWasAllocated <Boolean>
scavenger: <SpurGenerationScavenger>
biasForGC
- true if compacting for GC, in which case do only one pass, or false if compacting for snapshot, in which case do as many passes as necessary to compact the entire heap.
firstFieldOfRememberedSet
- the saved first field of the rememberedSet. The rememberedSet must be relocated specially because it is not a pointer object. And hence the first field needs to be extracted for proper relocation.
firstFreeObject
- the first free object in a compaction pass.
firstMobileObject
- the first mobile object in a compaction. Unpinned objects from the firstMobileObject through to the lastMobileObject are implicitly forwarded.
lastMobileObject
- the last mobile object in a compaction. Unpinned objects from the firstMobileObject through to the lastMobileObject are implicitly forwarded.
savedFirstFieldsSpace
- the space holding the saved first fields, each overwritten by a forwarding pointer, for the objects from firstMobileObject through to lastMobileObject.
savedFirstFieldsSpaceWasAllocated
- if true, the memory for savedFirstFieldsSpace was obtained via a call of sqAllocateMemorySegmentOfSize:Above:AllocatedSizeInto:!
Item was changed:
----- Method: SpurPlanningCompactor class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
+ self declareCAsOop: (self instVarNames select: [:iv| iv endsWith: 'Object']) in: aCCodeGenerator.
aCCodeGenerator
var: 'savedFirstFieldsSpace' type: #SpurContiguousObjStack;
+ removeVariable: 'interestingObj';
+ removeVariable: 'relocationMap'!
- removeVariable: 'interestingObj'!
Item was added:
+ ----- Method: SpurPlanningCompactor class>>identifySignedComparisons (in category 'analysis') -----
+ identifySignedComparisons
+ "self identifySignedComparisons"
+ | vmm cg noise |
+ noise := #('(manager bytesInObject: largestFreeChunk) >= spaceEstimate'
+ '(self classIndexOf: o*) > self isForwardedObjectClassIndexPun'
+ 'GCModeFull > 0'
+ 'ReceiverIndex + (objectMemory integerValueOf: sp*) < (objectMemory lengthOf: o*)'
+ 'availableSpace > 0'
+ 'bytes + 2 * 8 > availableSpace'
+ 'fmt* < manager firstCompiledMethodFormat'
+ 'fmt* < self firstCompiledMethodFormat'
+ 'fmt* <= 5'
+ 'gcPhaseInProgress > 0'
+ 'i <= finishIndex'
+ 'i >= 0'
+ 'numPointerSlots > 0'
+ 'scavenger rememberedSetSize > 0').
+ vmm := (VMMaker forPlatform: 'Cross')
+ interpreterClass: StackInterpreter;
+ options: #(ObjectMemory Spur32BitMemoryManager).
+ cg := [vmm buildCodeGeneratorForInterpreter]
+ on: Notification
+ do: [:ex|
+ ex tag == #getVMMaker
+ ifTrue: [ex resume: vmm]
+ ifFalse: [ex pass]].
+ cg vmClass preGenerationHook: cg.
+ cg inferTypesForImplicitlyTypedVariablesAndMethods.
+ cg retainMethods: self selectors.
+ cg prepareMethods.
+ cg doInlining: true.
+ self selectors sort do:
+ [:sel|
+ (cg methodNamed: sel) ifNotNil:
+ [:m|
+ m parseTree nodesDo:
+ [:node|
+ (node isSend
+ and: [(#(< > <= >=) includes: node selector)
+ and: [({node receiver. node args first } anySatisfy:
+ [:o| (cg typeFor: o in: m)
+ ifNil: [true]
+ ifNotNil: [:t| (cg isIntegralCType: t) and: [t first ~= $u]]])
+ and: [noise noneSatisfy: [:n| n match: node printString]]]]) ifTrue:
+ [Transcript ensureCr; nextPutAll: sel; space; print: node; flush]]]]!
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.
- objectAfterLastMobileObject := manager objectAfter: lastMobileObject.
self updatePointers.
self copyAndUnmark: firstPass.
manager checkFreeSpace: GCModeFull.
onePass or: [biasForGC]] whileFalse:
[firstPass := false.
self reinitializeScan;
updateSavedFirstFieldsSpaceIfNecessary].
self endCompaction!
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 do:
[:o :n|
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]).
- o > lastMobileObject ifTrue:
- [self freeFrom: toFinger upTo: manager endOfMemory previousPin: previousPin.
- ^true].
(manager isMarked: o) ifTrue:
+ [o > lastMobileObject ifTrue:
+ [self assert: ((manager isPinned: o) not or: [previousPin isNil]).
+ self freeFrom: toFinger upTo: manager endOfMemory previousPin: ((manager isPinned: o) ifTrue: [o] ifFalse: [previousPin]).
+ ^true].
+ (manager isPinned: o)
- [(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 := manager objectAfter: 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:
[| done |
self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop).
done := self noMobileObjectsAfter: 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.
^true!
Item was changed:
----- Method: SpurPlanningCompactor>>copyAndUnmarkObject:to:bytes:firstField: (in category 'compaction') -----
copyAndUnmarkObject: o to: toFinger bytes: bytes firstField: firstField
"Copy the object to toFinger, clearing its mark bit and restoring its firstField, which was overwritten with a forwarding pointer.
Answer the number of bytes in the object, including overflow header."
<inline: true>
| numSlots destObj start |
numSlots := manager rawNumSlotsOf: o.
destObj := (manager objectWithRawSlotsHasOverflowHeader: numSlots)
ifTrue: [toFinger + manager baseHeaderSize]
ifFalse: [toFinger].
start := manager startOfObject: o given: numSlots.
+ "memmove must be used since the ranges may overlap."
manager
+ mem: toFinger asVoidPointer mo: start asVoidPointer ve: bytes;
- mem: toFinger asVoidPointer cp: start asVoidPointer y: bytes;
setIsMarkedOf: destObj to: false;
storePointerUnchecked: 0 ofObject: destObj withValue: firstField!
Item was changed:
----- Method: SpurPlanningCompactor>>findNextMarkedPinnedAfter: (in category 'private') -----
findNextMarkedPinnedAfter: unpinnedObj
<inline: true>
| nextObj |
self deny: ((manager isPinned: unpinnedObj) and: [manager isMarked: unpinnedObj]).
nextObj := unpinnedObj.
+ [nextObj := manager oldSpaceObjectAfter: nextObj.
+ (self oop: nextObj isGreaterThanOrEqualTo: manager endOfMemory) ifTrue:
- [nextObj := manager objectAfter: nextObj limit: manager endOfMemory.
- nextObj >= manager endOfMemory ifTrue:
[^nil].
(manager isPinned: nextObj) and: [manager isMarked: nextObj]] whileFalse.
^nextObj!
Item was changed:
----- Method: SpurPlanningCompactor>>forwardMobileObject:to:savedFirstFieldPtr: (in category 'private') -----
forwardMobileObject: o to: toFinger savedFirstFieldPtr: savedFirstFieldPtr
"Forward a mobile object to some new location, saving its first field through savedFirstFieldPtr.
Don't use forward:to:; we dont want to alter the object in any way other than by setting the forwarding pointer."
<inline: true>
lastMobileObject := o.
manager
longAt: savedFirstFieldPtr
put: (manager fetchPointer: 0 ofObject: o);
storePointerUnchecked: 0
ofObject: o
withValue: ((manager hasOverflowHeader: o)
ifTrue: [toFinger + manager baseHeaderSize]
ifFalse: [toFinger]).
+ self cCode: '' inSmalltalk: [relocationMap at: o put: savedFirstFieldPtr]!
- ^toFinger + (manager bytesInObject: o)!
Item was changed:
----- Method: SpurPlanningCompactor>>freeAllUnpinnedObjectsFromObject:toFinger: (in category 'private') -----
freeAllUnpinnedObjectsFromObject: nextObj toFinger: initialToFinger
"Free all space from toFinger up, preserving only marked pinned objects, clearning their marked bits."
| toFinger nextPinnedObj |
<var: 'toFinger' type: #usqInt>
<var: 'nextPinnedObj' type: #usqInt>
toFinger := initialToFinger.
nextPinnedObj := nextObj.
[[nextPinnedObj >= manager endOfMemory
or: [(manager isMarked: nextPinnedObj)
and: [manager isPinned: nextPinnedObj]]] whileFalse:
+ [nextPinnedObj := manager objectAfter: nextPinnedObj limit: manager endOfMemory].
- [nextPinnedObj := manager objectAfter: nextPinnedObj].
nextPinnedObj < manager endOfMemory] whileTrue:
[toFinger < (manager startOfObject: nextPinnedObj) ifTrue:
[manager addFreeChunkWithBytes: (manager startOfObject: nextPinnedObj) - toFinger at: toFinger].
self unmarkPinned: nextPinnedObj.
toFinger := manager addressAfter: nextPinnedObj.
+ nextPinnedObj := manager oldSpaceObjectAfter: nextPinnedObj].
- nextPinnedObj := manager objectAfter: nextPinnedObj].
toFinger < manager endOfMemory ifTrue:
[manager addFreeChunkWithBytes: manager endOfMemory - toFinger at: toFinger]!
Item was changed:
----- 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.
seg segLimit < limit ifTrue:
[pin := manager segmentManager bridgeFor: seg]].
[pin notNil] 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].
manager addFreeChunkWithBytes: limit - effectiveToFinger at: effectiveToFinger!
Item was changed:
----- Method: SpurPlanningCompactor>>initializeCompaction (in category 'compaction') -----
initializeCompaction
manager checkFreeSpace: GCModeFull.
self selectSavedFirstFieldsSpace.
self unpinRememberedSet.
manager
resetFreeListHeads;
totalFreeOldSpace: 0;
beginSlidingCompaction.
+ savedFirstFieldsSpace top: savedFirstFieldsSpace start - manager bytesPerOop.
+ self cCode: '' inSmalltalk: [relocationMap := Dictionary new]!
- savedFirstFieldsSpace top: savedFirstFieldsSpace start - manager bytesPerOop!
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 := manager objectAfter: 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.
^self noMobileObjectsAfter: o]]]].
savedFirstFieldsSpace top: top - manager bytesPerOop.
^true!
Item was changed:
----- Method: SpurPlanningCompactor>>savedFirstFieldsSpaceInFreeChunk (in category 'space management') -----
savedFirstFieldsSpaceInFreeChunk
<inline: true>
+ ^savedFirstFieldsSpaceNotInOldSpace not
+ and: [self oop: savedFirstFieldsSpace start isGreaterThan: manager nilObject]!
- ^savedFirstFieldsSpaceNotInOldSpace not and: [savedFirstFieldsSpace start >= manager nilObject]!
Item was changed:
----- Method: SpurPlanningCompactor>>savedFirstFieldsSpaceWasAllocated (in category 'space management') -----
savedFirstFieldsSpaceWasAllocated
<inline: true>
+ ^savedFirstFieldsSpaceNotInOldSpace
+ and: [self oop: savedFirstFieldsSpace start isGreaterThan: manager nilObject]!
- ^savedFirstFieldsSpaceNotInOldSpace and: [savedFirstFieldsSpace start >= manager nilObject]!
Item was changed:
----- Method: SpurPlanningCompactor>>unmarkPinnedObjectsAndFindFirstUnpinnedOrFreeEntityFollowing: (in category 'private') -----
unmarkPinnedObjectsAndFindFirstUnpinnedOrFreeEntityFollowing: pinnedObj
<inline: true>
| nextObj |
self assert: ((manager isPinned: pinnedObj) and: [manager isMarked: pinnedObj]).
nextObj := pinnedObj.
[self unmarkPinned: nextObj.
+ nextObj := manager oldSpaceObjectAfter: nextObj.
+ (self oop: nextObj isGreaterThanOrEqualTo: manager endOfMemory) ifTrue:
- nextObj := manager objectAfter: nextObj limit: manager endOfMemory.
- nextObj >= manager endOfMemory ifTrue:
[^manager endOfMemory].
(manager isPinned: nextObj) and: [manager isMarked: nextObj]] whileTrue.
^nextObj!
Item was changed:
----- Method: SpurPlanningCompactor>>updatePointersInInitialImmobileObjects (in category 'compaction') -----
updatePointersInInitialImmobileObjects
"Sweep the initial immobile heap, updating all references to mobile objects to their eventual locations."
manager allOldSpaceObjectsFrom: manager firstObject do:
[:o|
self check: o.
+ (self oop: o isGreaterThanOrEqualTo: firstFreeObject) ifTrue:
- o >= firstFreeObject ifTrue:
[^self].
self assert: (manager isMarked: o).
self updatePointersIn: o]!
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 := manager objectAfter: 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).
^self noMobileObjectsAfter: 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:
- manager allOldSpaceObjectsFrom: (manager objectAfter: lastMobileObject) do:
[:o|
self check: o.
self assert: (manager isMarked: o).
self updatePointersIn: o]!
Item was changed:
----- Method: SpurPlanningCompactor>>useSegmentForSavedFirstFieldsSpace: (in category 'space management') -----
useSegmentForSavedFirstFieldsSpace: spaceEstimate
"Attempt to allocate a memory segment large enough to hold the savedFirstFieldsSpace.
Invoked when neither eden nor a large free chunk are found to be big enough for the job."
| allocatedSize |
+ <var: #segAddress type: #'void *'>
(manager "sent to the manager so that the simulator can increase memory to simulate a new segment"
sqAllocateMemorySegmentOfSize: spaceEstimate
Above: (self firstGapOfSizeAtLeast: spaceEstimate)
AllocatedSizeInto: (self cCode: [self addressOf: allocatedSize]
inSmalltalk: [[:sz| allocatedSize := sz]])) ifNotNil:
[:segAddress|
savedFirstFieldsSpace
+ start: segAddress asUnsignedIntegerPtr;
+ limit: segAddress asUnsignedIntegerPtr + allocatedSize.
- start: segAddress;
- limit: segAddress + allocatedSize.
savedFirstFieldsSpaceNotInOldSpace := true.
self assert: self savedFirstFieldsSpaceWasAllocated.
^true].
^false!
Item was changed:
----- Method: SpurSegmentInfo>>segLimit (in category 'accessing') -----
segLimit
+ <returnTypeC: #usqInt>
^segSize + segStart!
Item was changed:
----- Method: SpurSegmentManager>>notePinned: (in category 'pinning') -----
notePinned: objOop
"Let the segmentManager mark which segments contain pinned objects"
self assert: (manager isPinned: objOop).
(manager isSegmentBridge: objOop)
ifTrue:
[manager setIsMarkedOf: objOop to: true]
ifFalse:
+ [[self oop: (segments at: sweepIndex) segLimit isLessThan: objOop] whileTrue:
- [[(segments at: sweepIndex) segLimit < objOop] whileTrue:
[sweepIndex := sweepIndex + 1].
(segments at: sweepIndex) containsPinned: true]!
Item was changed:
----- Method: StackInterpreter>>commonVariable:at:put:cacheIndex: (in category 'indexing primitive support') -----
commonVariable: rcvr at: index put: value cacheIndex: atIx
"This code assumes the receiver has been identified at location atIx in the atCache."
+ <returnTypeC: #void>
| stSize fmt fixedFields valToPut isCharacter |
<inline: true>
stSize := atCache at: atIx+AtCacheSize.
((self oop: index isGreaterThanOrEqualTo: 1)
and: [self oop: index isLessThanOrEqualTo: stSize]) ifTrue:
[fmt := atCache at: atIx+AtCacheFmt.
fmt <= objectMemory weakArrayFormat ifTrue:
[self assert: (objectMemory isContextNonImm: rcvr) not.
fixedFields := atCache at: atIx+AtCacheFixedFields.
^objectMemory storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value].
fmt < objectMemory firstByteFormat ifTrue: "64, 32, & 16 bits"
[objectMemory hasSpurMemoryManagerAPI ifTrue:
[fmt >= objectMemory firstShortFormat ifTrue:
[valToPut := (objectMemory isIntegerObject: value)
ifTrue: [objectMemory integerValueOf: value]
ifFalse: [-1].
(valToPut >= 0 and: [valToPut <= 65535]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument].
^objectMemory storeShort16: index - 1 ofObject: rcvr withValue: valToPut].
fmt = objectMemory sixtyFourBitIndexableFormat ifTrue:
[| val64ToPut |
val64ToPut := self positive64BitValueOf: value.
self successful ifTrue:
[^objectMemory storeLong64: index - 1 ofObject: rcvr withValue: val64ToPut].
^self primitiveFailFor: PrimErrBadArgument]].
valToPut := self positive32BitValueOf: value.
self successful ifTrue:
[^objectMemory storeLong32: index - 1 ofObject: rcvr withValue: valToPut].
^self primitiveFailFor: PrimErrBadArgument].
fmt >= objectMemory firstStringyFakeFormat "Note fmt >= firstStringyFormat is an artificial flag for strings"
ifTrue:
[isCharacter := objectMemory isCharacterObject: value.
isCharacter ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
objectMemory hasSpurMemoryManagerAPI
ifTrue: [valToPut := objectMemory characterValueOf: value]
ifFalse:
[valToPut := objectMemory fetchPointer: CharacterValueIndex ofObject: value.
valToPut := (objectMemory isIntegerObject: valToPut)
ifTrue: [objectMemory integerValueOf: valToPut]
ifFalse: [-1]].
objectMemory hasSpurMemoryManagerAPI ifTrue:
[fmt < (objectMemory firstByteFormat + objectMemory firstStringyFakeFormat) ifTrue:
[fmt < (objectMemory firstShortFormat + objectMemory firstStringyFakeFormat)
ifTrue:
[self assert: fmt ~= (objectMemory sixtyFourBitIndexableFormat + objectMemory firstStringyFakeFormat).
^objectMemory storeLong32: index - 1 ofObject: rcvr withValue: valToPut]
ifFalse:
[(valToPut >= 0 and: [valToPut <= 65535]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument].
^objectMemory storeShort16: index - 1 ofObject: rcvr withValue: valToPut]]]]
ifFalse:
[(fmt >= objectMemory firstCompiledMethodFormat
and: [index < (self firstByteIndexOfMethod: rcvr)]) ifTrue:
[^self primitiveFailFor: PrimErrBadIndex].
valToPut := (objectMemory isIntegerObject: value)
ifTrue: [objectMemory integerValueOf: value]
ifFalse: [-1]].
(valToPut >= 0 and: [valToPut <= 255]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument].
^objectMemory storeByte: index - 1 ofObject: rcvr withValue: valToPut].
^self primitiveFailFor: ((objectMemory isIndexable: rcvr)
ifFalse: [PrimErrBadReceiver]
ifTrue: [PrimErrBadIndex])!
Item was changed:
----- Method: VMClass>>mem:cp:y: (in category 'C library simulation') -----
+ mem: dString cp: sString y: bytes
- mem: aString cp: bString y: n
<doNotGenerate>
+ "implementation of memcpy(3). N.B. If ranges overlap, must use memmove."
+ (dString isString or: [sString isString]) ifFalse:
+ [| destAddress sourceAddress |
+ destAddress := dString asInteger.
+ sourceAddress := sString asInteger.
+ self deny: ((destAddress <= sourceAddress and: [destAddress + bytes > sourceAddress])
+ or: [sourceAddress <= destAddress and: [sourceAddress + bytes > destAddress]])].
+ dString isString
- "implementation of memcpy(3)"
- aString isString
ifTrue:
+ [1 to: bytes do:
- [1 to: n do:
[:i| | v |
+ v := sString isString
+ ifTrue: [sString at: i]
+ ifFalse: [Character value: (self byteAt: sString + i - 1)].
+ dString at: i put: v]]
- v := bString isString
- ifTrue: [bString at: i]
- ifFalse: [Character value: (self byteAt: bString + i - 1)].
- aString at: i put: v]]
ifFalse:
+ [1 to: bytes do:
- [1 to: n do:
[:i| | v |
+ v := sString isString
+ ifTrue: [(sString at: i) asInteger]
+ ifFalse: [self byteAt: sString + i - 1].
+ self byteAt: dString + i - 1 put: v]].
+ ^dString!
- v := bString isString
- ifTrue: [(bString at: i) asInteger]
- ifFalse: [self byteAt: bString + i - 1].
- self byteAt: aString + i - 1 put: v]].
- ^aString!
More information about the Vm-dev
mailing list