VM Maker: VMMaker.oscog-eem.731.mcz

 
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.731.mcz

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

Name: VMMaker.oscog-eem.731
Author: eem
Time: 21 May 2014, 3:44:59.389 pm
UUID: e19b7342-8c8a-4ad8-8acd-64a6c1a7544d
Ancestors: VMMaker.oscog-eem.730

Spur:
Implement primitives to get (primitiveIsPinned) and (un)set
(primitivePin) per-object pinning.

=============== Diff against VMMaker.oscog-eem.730 ===============

Item was added:
+ ----- Method: InterpreterPrimitives>>primitiveIsPinned (in category 'memory space primitives') -----
+ primitiveIsPinned
+ "Answer if the receiver is pinned, i.e. immobile."
+ | receiver |
+ receiver := self stackTop.
+ ((objectMemory isImmediate: receiver)
+ or: [objectMemory isForwarded: receiver]) ifTrue:
+ [^self primitiveFailFor: PrimErrBadReceiver].
+ self pop: argumentCount - 1.
+ self stackTopPut:
+ (objectMemory hasSpurMemoryManagerAPI
+ ifTrue: [objectMemory booleanObjectOf: (objectMemory isPinned: receiver)]
+ ifFalse: [objectMemory falseObject])!

Item was added:
+ ----- Method: InterpreterPrimitives>>primitivePin (in category 'memory space primitives') -----
+ primitivePin
+ "Pin or unpin the receiver, i.e. make it immobile or mobile.  Answer whether the object was
+ already pinned. N.B. pinning does *not* prevent an object from being garbage collected."
+ | receiver boolean wasPinned failure |
+ objectMemory hasSpurMemoryManagerAPI ifFalse:
+ [^self primitiveFailFor: PrimErrUnsupported].
+
+ receiver := self stackValue: 1.
+ ((objectMemory isImmediate: receiver)
+ or: [(objectMemory isForwarded: receiver)
+ or: [(objectMemory isContext: receiver)
+ and: [self isStillMarriedContext: receiver]]]) ifTrue:
+ [^self primitiveFailFor: PrimErrBadReceiver].
+ boolean := self stackTop.
+ (boolean = objectMemory falseObject
+ or: [boolean = objectMemory trueObject]) ifFalse:
+ [^self primitiveFailFor: PrimErrBadArgument].
+
+ (objectMemory isPinned: receiver)
+ ifTrue:
+ [wasPinned := objectMemory trueObject.
+ objectMemory setIsPinnedOf: receiver to: false]
+ ifFalse:
+ [wasPinned := objectMemory falseObject.
+ failure := objectMemory pinObject: receiver.
+ failure ~= 0 ifTrue:
+ [^self primitiveFailFor: failure]].
+
+ self pop: argumentCount - 1 thenPush: wasPinned!

Item was added:
+ ----- Method: Spur32BitMemoryManager>>allocateSlotsForPinningInOldSpace:bytes:format:classIndex: (in category 'allocation') -----
+ allocateSlotsForPinningInOldSpace: numSlots bytes: totalBytes format: formatField classIndex: classIndex
+ "Answer the oop of a chunk of space in oldSpace with numSlots slots.  Try and
+ allocate in a segment that already includes pinned objects.  The header of the
+ result will have been filled-in but not the contents."
+ <inline: false>
+ | chunk |
+ chunk := self allocateOldSpaceChunkOfBytes: totalBytes
+   suchThat: [:f| (segmentManager segmentContainingObj: f) containsPinned].
+ chunk ifNil:
+ [chunk := self allocateOldSpaceChunkOfBytes: totalBytes.
+ chunk ifNotNil:
+ [(segmentManager segmentContainingObj: chunk) containsPinned: true]].
+ self checkFreeSpace.
+ chunk ifNil:
+ [^nil].
+ numSlots >= self numSlotsMask ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word"
+ [self flag: #endianness.
+ self longAt: chunk put: numSlots.
+ self longAt: chunk + 4 put: self numSlotsMask << self numSlotsHalfShift.
+ self long64At: chunk + self baseHeaderSize
+ put: (self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex).
+ ^chunk + self baseHeaderSize].
+ self long64At: chunk put: (self headerForSlots: numSlots format: formatField classIndex: classIndex).
+ ^chunk!

Item was added:
+ ----- Method: Spur64BitMemoryManager>>allocateSlotsForPinningInOldSpace:bytes:format:classIndex: (in category 'allocation') -----
+ allocateSlotsForPinningInOldSpace: numSlots bytes: totalBytes format: formatField classIndex: classIndex
+ "Answer the oop of a chunk of space in oldSpace with numSlots slots.  Try and
+ allocate in a segment that already includes pinned objects.  The header of the
+ result will have been filled-in but not the contents."
+ <inline: false>
+ | chunk |
+ chunk := self allocateOldSpaceChunkOfBytes: totalBytes
+   suchThat: [:f| (segmentManager segmentContainingObj: f) containsPinned].
+ chunk ifNil:
+ [chunk := self allocateOldSpaceChunkOfBytes: totalBytes].
+ self checkFreeSpace.
+ chunk ifNil:
+ [^nil].
+ numSlots >= self numSlotsMask ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word"
+ [self longAt: chunk
+ put: numSlots + (self numSlotsMask << self numSlotsFullShift).
+ self longAt: chunk + self baseHeaderSize
+ put: (self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex).
+ ^chunk + self baseHeaderSize].
+ self longAt: chunk
+ put: (self headerForSlots: numSlots format: formatField classIndex: classIndex).
+ ^chunk!

Item was added:
+ ----- 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."
+ | initialIndex node next prev index child childBytes acceptedChunk acceptedNode |
+ <inline: true> "must inline for acceptanceBlock"
+ self assert: (lastSubdividedFreeChunk := 0) = 0.
+ "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 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 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 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 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 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 added:
+ ----- Method: SpurMemoryManager>>cloneInOldSpaceForPinning: (in category 'allocation') -----
+ cloneInOldSpaceForPinning: objOop
+ | numSlots newObj |
+ numSlots := self numSlotsOf: objOop.
+
+ newObj := self allocateSlotsForPinningInOldSpace: numSlots
+ bytes: (self objectBytesForSlots: numSlots)
+ format: (self formatOf: objOop)
+ classIndex: (self classIndexOf: objOop).
+ (self isPointersNonImm: objOop)
+ ifTrue:
+ [| hasYoung |
+ hasYoung := false.
+ 0 to: numSlots - 1 do:
+ [:i| | oop |
+ oop := self fetchPointer: i ofObject: objOop.
+ ((self isNonImmediate: oop)
+ and: [self isForwarded: oop]) ifTrue:
+ [oop := self followForwarded: oop].
+ ((self isNonImmediate: oop)
+ and: [self isYoungObject: oop]) ifTrue:
+ [hasYoung := true].
+ self storePointerUnchecked: i
+ ofObject: newObj
+ withValue: oop].
+ (hasYoung
+ and: [(self isYoungObject: newObj) not]) ifTrue:
+ [scavenger remember: newObj.
+ self setIsRememberedOf: newObj to: true]]
+ ifFalse:
+ [0 to: numSlots - 1 do:
+ [:i|
+ self storePointerUnchecked: i
+ ofObject: newObj
+ withValue: (self fetchPointer: i ofObject: objOop)]].
+ ^newObj!

Item was changed:
  ----- Method: SpurMemoryManager>>pinObject: (in category 'primitive support') -----
  pinObject: objOop
+ | oldClone seg |
+ <var: #seg type: #'SpurSegmentInfo *'>
+ self assert: (self isNonImmediate: objOop).
+ self flag: 'policy decision here. if already old, do we clone in a segment containing pinned objects or merely pin?'.
+ "We choose to clone to keep pinned objects together to reduce fragmentation,
+ assuming that pinning is rare and that fragmentation is a bad thing."
+ (self isOldObject: objOop) ifTrue:
+ [seg := segmentManager segmentContainingObj: objOop.
+ seg containsPinned ifTrue:
+ [self setIsPinnedOf: objOop to: true.
+ ^0].
+ segmentManager someSegmentContainsPinned ifFalse:
+ [self setIsPinnedOf: objOop to: true.
+ seg containsPinned: true.
+ ^0]].
+ oldClone := self cloneInOldSpaceForPinning: objOop.
+ oldClone = 0 ifTrue:
+ [^PrimErrNoMemory].
+ self setIsPinnedOf: oldClone to: true.
+ self forward: objOop to: oldClone.
+ ^0!
- "Pin objOop in memory.  If objOop is in oldSpace merely set its isPinned
- bit.  If objOop is in newSpace then created a pinned copy in oldSpace
- and forward objOop to the pinned copy.  Answer the (possibly changed)
- oop of the pinned object."
- <api>
- self shouldBeImplemented!

Item was added:
+ ----- Method: SpurSegmentManager>>someSegmentContainsPinned (in category 'pinning') -----
+ someSegmentContainsPinned
+ 0 to: numSegments - 1 do:
+ [:i| (segments at: i) containsPinned ifTrue: [^true]].
+ ^false!

Item was changed:
  ----- Method: StackInterpreter class>>initializePrimitiveTable (in category 'initialization') -----
(excessive size, no diff calculated)