Quantcast

VM Maker: VMMaker.oscog-eem.2061.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.oscog-eem.2061.mcz

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

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

Name: VMMaker.oscog-eem.2061
Author: eem
Time: 31 December 2016, 10:45:17.323259 am
UUID: ccfa5cc9-714b-40dc-abf1-b873b476a45a
Ancestors: VMMaker.oscog-eem.2060

Simulator:
Use Levente's lock-free growth of the externalSemaphoreSignalRequests/Responses code.

Turn off logging in the SocketPluginSimulator now that it can do an update.

SpurPlanningCompactor:
Add an assert to check that all marked and unpinned objects in the mobile range are actually mobile, and hence uncover the bug in planCompactSavingForwarders.

Fix the bug in planCompactSavingForwarders (the rest to follow).

Add an interestingObject and halt the enumerations at it for debugging (simulation only).

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

Item was changed:
  ----- Method: CogVMSimulator>>signalSemaphoreWithIndex: (in category 'process primitive support') -----
  signalSemaphoreWithIndex: index
+ "This is a simulation.  See platforms/Cross/vm/sqExternalSemaphores.c for the real code.
+ Thanks to Levente Uzoni for making this version almost thread-safe (in Smalltalk)"
+ <doNotGenerate>
+ | originalResponses newRequests newResponses |
- "This is a non-thread-safe simulation.  See platforms/Cross/vm/sqExternalSemaphores.c
- for the real code."
  index <= 0 ifTrue: [^false].
  index > externalSemaphoreSignalRequests size ifTrue:
+ [newRequests := Array new: 1 << index highBit withAll: 0.
+ newResponses := newRequests shallowCopy].
+ "This is a lock-free thread-safe grow...; thanks Levente"
+ originalResponses := externalSemaphoreSignalResponses.
+ [index > externalSemaphoreSignalRequests size] whileTrue:
+ [newRequests
- [| newRequests newResponses |
- newRequests := Array new: 1 << index highBit withAll: 0.
- newResponses := newRequests copy.
- newRequests
  replaceFrom: 1
  to: externalSemaphoreSignalRequests size
  with: externalSemaphoreSignalRequests
  startingAt: 1.
+ newResponses
- newResponses
  replaceFrom: 1
  to: externalSemaphoreSignalResponses size
  with: externalSemaphoreSignalResponses
+ startingAt: 1.
+ externalSemaphoreSignalResponses == originalResponses "This should always be true."
+ ifTrue:
+ [externalSemaphoreSignalRequests := newRequests.
+ externalSemaphoreSignalResponses := newResponses]
+ ifFalse:
+ [originalResponses := externalSemaphoreSignalResponses]].
+ "This is not thread-safe however..."
- startingAt: 1].
  externalSemaphoreSignalRequests
  at: index
  put: (externalSemaphoreSignalRequests at: index) + 1.
  ^true!

Item was changed:
  ----- Method: SocketPluginSimulator>>simulator: (in category 'accessing') -----
  simulator: aSmartSyntaxPluginSimulator
  super simulator: aSmartSyntaxPluginSimulator.
+ "aSmartSyntaxPluginSimulator logging: true"!
- aSmartSyntaxPluginSimulator logging: true!

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

Item was changed:
  CogClass subclass: #SpurPlanningCompactor
+ instanceVariableNames: 'manager scavenger coInterpreter biasForGC firstFreeObject mobileStart firstMobileObject lastMobileObject savedFirstFieldsSpace savedFirstFieldsSpaceWasAllocated firstFieldOfRememberedSet interestingObj anomaly'
- instanceVariableNames: 'manager scavenger coInterpreter biasForGC firstFreeObject firstMobileObject lastMobileObject savedFirstFieldsSpace savedFirstFieldsSpaceWasAllocated firstFieldOfRememberedSet'
  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
+ aCCodeGenerator
+ var: 'savedFirstFieldsSpace' type: #SpurContiguousObjStack;
+ removeVariable: 'interestingObj'!
- aCCodeGenerator var: 'savedFirstFieldsSpace' type: #SpurContiguousObjStack!

Item was added:
+ ----- Method: SpurPlanningCompactor>>check: (in category 'private') -----
+ check: obj
+ <inline: true>
+ self cCode: '' inSmalltalk: [obj = interestingObj ifTrue: [self halt]]!

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 |
  <inline: #never> "for profiling"
  self initializeScanCheckingForFullyCompactedHeap ifTrue:
  [^self unmarkObjectsInFullyCompactedHeap].
  self initializeCompaction.
  [onePass := self planCompactSavingForwarders.
+ self assert: (self validRelocationPlanInPass: onePass) = 0.
  self updatePointers.
  self copyAndUnmark.
  manager checkFreeSpace: GCModeFull.
  onePass or: [biasForGC]] whileFalse:
  [self reinitializeScan;
  updateSavedFirstFieldsSpaceIfNecessary].
  self endCompaction!

Item was removed:
- ----- Method: SpurPlanningCompactor>>continuePlanCompactSavingForwardersFrom: (in category 'compaction') -----
- continuePlanCompactSavingForwardersFrom: anUnpinnedEntity
- "planCompactSavingForwarders has encountered a run of pinned objects around which
- it cannot compact, but savedFirstFieldsSpace is still not full.  Continue the pass with a
- new firstFreeObject, resetting it before continuing.
- Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed)."
- | result savedFirstFreeObject savedFirstMobileObject nextFreeObject |
- self assert: (self oop: anUnpinnedEntity isLessThan: manager endOfMemory).
- self deny: (manager isPinned: anUnpinnedEntity).
- savedFirstFreeObject := firstFreeObject.
- savedFirstMobileObject := firstMobileObject.
- nextFreeObject := self scanForFirstFreeAndFirstMobileObjectFrom: anUnpinnedEntity.
- firstMobileObject := savedFirstMobileObject.
- nextFreeObject ifNil:
- [^true].
- firstFreeObject := nextFreeObject.
- result := self planCompactSavingForwarders.
- firstFreeObject := savedFirstFreeObject.
- ^result!

Item was added:
+ ----- Method: SpurPlanningCompactor>>continuePlanCompactSavingForwardersFrom:toFinger: (in category 'compaction') -----
+ continuePlanCompactSavingForwardersFrom: anUnpinnedEntity toFinger: initialToFinger
+ "planCompactSavingForwarders has encountered a run of pinned objects around which
+ it cannot compact, but savedFirstFieldsSpace is still not full.  Continue the pass with a
+ new firstFreeObject, resetting it before continuing.
+ Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed)."
+ | result toFinger savedFirstMobileObject nextFreeObject |
+ self assert: (self oop: anUnpinnedEntity isLessThan: manager endOfMemory).
+ self deny: (manager isPinned: anUnpinnedEntity).
+ toFinger := initialToFinger.
+ savedFirstMobileObject := firstMobileObject.
+ nextFreeObject := self scanForFirstFreeAndFirstMobileObjectFrom: anUnpinnedEntity.
+ manager allOldSpaceEntitiesFrom: anUnpinnedEntity to: firstMobileObject do:
+ [:o| | newTop |
+ (o < firstMobileObject
+  and: [manager isMarked: o]) ifTrue:
+ [(manager isPinned: o)
+ ifTrue: [self assert: (manager addressAfter: o) <= initialToFinger]
+ ifFalse:
+ [(newTop := savedFirstFieldsSpace top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
+ [firstMobileObject := savedFirstMobileObject.
+ ^false]].
+ self assert: (manager startOfObject: o) >= toFinger.
+ manager
+ longAt: newTop
+ put: (manager fetchPointer: 0 ofObject: o);
+ storePointerUnchecked: 0
+ ofObject: o
+ withValue: ((manager hasOverflowHeader: o)
+ ifTrue: [toFinger + manager baseHeaderSize]
+ ifFalse: [toFinger]).
+ savedFirstFieldsSpace top: newTop.
+ toFinger := toFinger + (manager bytesInObject: o).
+ lastMobileObject := o]].
+ firstMobileObject := savedFirstMobileObject.
+ nextFreeObject ifNil:
+ [^true].
+ self assert: nextFreeObject > lastMobileObject.
+ manager allOldSpaceEntitiesFrom: (manager objectAfter: lastMobileObject) to: nextFreeObject do:
+ [:o|
+ self deny: ((manager isMarked: o) and: [(manager isPinned: o) not])].
+ firstFreeObject := nextFreeObject.
+ result := self planCompactSavingForwarders.
+ ^result!

Item was changed:
  ----- Method: SpurPlanningCompactor>>copyAndUnmarkMobileObjectsWithTop: (in category 'compaction') -----
  copyAndUnmarkMobileObjectsWithTop: initialTop
  "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.
  This enumeration matches those in planCompactSavingForwarders and updatePointersInMobileObjects."
 
  | toFinger top previousPin |
  toFinger := manager startOfObject: firstFreeObject.
  top := initialTop.
  self deny: (manager isMarked: firstFreeObject).
  manager allOldSpaceEntitiesForCompactingFrom: firstFreeObject do:
  [:o| | availableSpace |
+ self check: o.
  self assert: (previousPin isNil or: [toFinger < previousPin]).
  (manager isMarked: o) ifTrue:
  [(manager isPinned: o)
  ifTrue:
  [(manager isSegmentBridge: o) ifFalse:
  [manager setIsMarkedOf: o to: false.
  manager segmentManager notePinned: o].
  previousPin ifNotNil:
  [| limit |
  limit := manager startOfObject: previousPin.
  manager addFreeChunkWithBytes: limit - toFinger at: toFinger.
  toFinger := manager addressAfter: previousPin.
  self assert: toFinger < (manager startOfObject: o)].
  previousPin := o]
  ifFalse:
  [| bytes next |
  (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
  [self freeFrom: toFinger upTo: (manager startOfObject: o) previousPin: previousPin.
  ^false].
  [previousPin notNil
   and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
  bytes := manager bytesInObject: o.
  bytes ~= availableSpace
  and: [bytes + (2 * manager allocationUnit) < availableSpace]]] whileTrue:
  ["The object does not fit in the space between toFinger and previousPin.
   Move toFinger beyond previousPin and update previousPin appropriately."
  availableSpace > 0 ifTrue:
  [manager addFreeChunkWithBytes: availableSpace at: toFinger].
  toFinger := manager addressAfter: previousPin.
  next := manager objectStartingAt: toFinger.
  next >= o ifTrue:
  [^self continueCopyAndUnmarkMobileObjectsFrom: next withTop: top].
  previousPin := (manager isPinned: next) ifTrue: [next]].
  bytes := self copyAndUnmarkObject: o to: toFinger firstField: (manager longAt: top).
  toFinger := toFinger + bytes]]].
  self freeFrom: toFinger upTo: manager endOfMemory previousPin: previousPin.
  ^true!

Item was added:
+ ----- Method: SpurPlanningCompactor>>interestingObj: (in category 'instance initialization') -----
+ interestingObj: obj
+ interestingObj := obj!

Item was changed:
  ----- Method: SpurPlanningCompactor>>isMobile: (in category 'private') -----
  isMobile: obj
  <inline: true>
+ ^(self oop: obj isGreaterThanOrEqualTo: mobileStart andLessThanOrEqualTo: lastMobileObject)
- ^(self oop: obj isGreaterThanOrEqualTo: firstMobileObject andLessThanOrEqualTo:  lastMobileObject)
  and: [(manager isPinned: obj) not]!

Item was changed:
  ----- Method: SpurPlanningCompactor>>isPostMobile: (in category 'private') -----
  isPostMobile: obj
  "For asserts"
+ ^self oop: obj isGreaterThanOrEqualTo: mobileStart andLessThanOrEqualTo: lastMobileObject!
- ^self oop: obj isGreaterThanOrEqualTo: firstFreeObject andLessThanOrEqualTo:  lastMobileObject!

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).
 
  Note that this method is potentially recursive. If skipping a run of pinned objects
  causes the the algorithm to encounter another run of immobile objects it will
  recurse via continuePlanCompactSavingForwardersFrom:.
 
  This enumeration matches those in updatePointersInMobileObjects and copyAndUnmarkMobileObjects."
 
  | toFinger top previousPin |
  savedFirstFieldsSpace top < savedFirstFieldsSpace start ifTrue:
  [self logPhase: 'planning...'].
  toFinger := manager startOfObject: firstFreeObject.
  top := savedFirstFieldsSpace top.
  self deny: (manager isMarked: firstFreeObject).
  manager allOldSpaceEntitiesFrom: firstFreeObject do:
  [:o|
+ self check: o.
  self assert: (previousPin isNil or: [toFinger < previousPin]).
  (manager isMarked: o) ifTrue:
  [(manager isPinned: o)
  ifTrue: "The empty gaps between two adjacent pinned objects (when not filled below) are freed."
  [previousPin ifNotNil:
  [self assert: (manager startOfObject: previousPin) - toFinger >= (manager allocationUnit * 2).
  toFinger := manager addressAfter: previousPin.
  self assert: toFinger < (manager startOfObject: o)].
  previousPin := o]
  ifFalse:
  [| availableSpace bytes next |
  (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
+ [savedFirstFieldsSpace top: top - manager bytesPerOop.
- [savedFirstFieldsSpace top: top.
  ^false].
  [previousPin notNil
   and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
  bytes := manager bytesInObject: o.
  bytes ~= availableSpace
  and: [bytes + (2 * manager allocationUnit) < availableSpace]]] whileTrue:
  ["The object does not fit in the space between toFinger and previousPin.
   Move toFinger beyond previousPin and update previousPin appropriately."
  toFinger := manager addressAfter: previousPin.
  next := manager objectStartingAt: toFinger.
  next >= o ifTrue:
+ [savedFirstFieldsSpace top: top - manager bytesPerOop.
+ ^self continuePlanCompactSavingForwardersFrom: o toFinger: toFinger].
- [savedFirstFieldsSpace top: top.
- ^self continuePlanCompactSavingForwardersFrom: next].
  previousPin := (manager isPinned: next) ifTrue: [next]].
  lastMobileObject := o.
  manager
  longAt: top put: (manager fetchPointer: 0 ofObject: o);
  storePointerUnchecked: 0 "Don't use forward:to:; we dont want to alter the object in any way other than by setting the forwarding pointer"
  ofObject: o
  withValue: ((manager hasOverflowHeader: o)
  ifTrue: [toFinger + manager baseHeaderSize]
  ifFalse: [toFinger]).
  toFinger := toFinger + (manager bytesInObject: o)]]].
  savedFirstFieldsSpace top: top.
  ^true!

Item was changed:
  ----- Method: SpurPlanningCompactor>>reinitializeScan (in category 'compaction') -----
  reinitializeScan
  firstMobileObject := manager endOfMemory.
  firstFreeObject := self scanForFirstFreeAndFirstMobileObjectFrom: firstFreeObject.
  firstFreeObject ifNil:
+ [self error: 'uncompactable heap; no unmarked objects found'].
+ mobileStart := manager startOfObject: firstFreeObject!
- [self error: 'uncompactable heap; no unmarked objects found']!

Item was changed:
  ----- Method: SpurPlanningCompactor>>unmarkInitialImmobileObjects (in category 'compaction') -----
  unmarkInitialImmobileObjects
  "Sweep the initial immobile heap, unmarking all objects up to the first mobile object."
  manager allOldSpaceObjectsFrom: manager firstObject do:
  [:o|
+ self check: o.
  o >= firstMobileObject ifTrue:
  [^self].
  manager setIsMarkedOf: o to: false]!

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.
  o >= firstFreeObject ifTrue:
  [^self].
  self assert: (manager isMarked: o).
  self updatePointersIn: o]!

Item was changed:
  ----- Method: SpurPlanningCompactor>>updatePointersInMobileObjectsWithTop: (in category 'compaction') -----
  updatePointersInMobileObjectsWithTop: initialTop
  "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.
  This enumeration matches that in planCompactSavingForwarders and copyAndUnmarkMobileObjects."
 
  | toFinger top previousPin |
  toFinger := manager startOfObject: firstFreeObject.
  top := initialTop.
  self deny: (manager isMarked: firstFreeObject).
  manager allOldSpaceEntitiesFrom: firstFreeObject do:
  [:o|
+ self check: o.
  self assert: (previousPin isNil or: [toFinger < previousPin]).
  (manager isMarked: o) ifTrue:
  [(manager isPinned: o)
  ifTrue: "The empty gaps between two adjacent pinned objects (when not filled below) are freed."
  [self updatePointersIn: o.
  previousPin ifNotNil:
  [toFinger := manager addressAfter: previousPin].
  previousPin := o]
  ifFalse:
  [| availableSpace bytes next |
  (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue:
  [^false].
  [previousPin notNil
   and: [availableSpace := (manager startOfObject: previousPin) - toFinger.
  bytes := manager bytesInObject: o.
  bytes ~= availableSpace
  and: [bytes + (2 * manager allocationUnit) < availableSpace]]] whileTrue:
  ["The object does not fit in the space between toFinger and previousPin.
   Move toFinger beyond previousPin and update previousPin appropriately."
  toFinger := manager addressAfter: previousPin.
  next := manager objectStartingAt: toFinger.
  next >= o ifTrue:
  [^self continueUpdatePointersInMobileObjectsFrom: next withTop: top].
  previousPin := (manager isPinned: next) ifTrue: [next]].
  self updatePointersIn: o savedFirstFieldPointer: top.
  toFinger := toFinger + (manager bytesInObject: o)]]].
  ^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: (manager objectAfter: lastMobileObject) do:
  [:o|
+ self check: o.
  self assert: (manager isMarked: o).
  self updatePointersIn: o]!

Item was changed:
  ----- Method: SpurPlanningCompactor>>updatePointersInSurvivingObjects (in category 'compaction') -----
  updatePointersInSurvivingObjects
  "Sweep pastSpace, updating all references to mobile objects to their eventual locations."
  manager allPastSpaceObjectsDo:
  [:o|
+ self check: o.
  self assert: (manager isMarked: o).
  self updatePointersIn: o]!

Item was added:
+ ----- 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 |
+ 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).
+ o > lastMobileObject ifTrue:
+ [anomaly := o. ^2].
+ o = lastMobileObject ifTrue:
+ [^savedFirstFieldsSpace top - savedFirstFieldsSpace start / manager bytesPerOop + 1
+   = nMobiles
+ ifTrue: [0]
+ ifFalse: [3]]]]].
+ ^savedFirstFieldsSpace top - savedFirstFieldsSpace start / manager bytesPerOop + 1
+  = nMobiles
+ ifTrue: [0]
+ ifFalse: [3]!

Item was changed:
  ----- Method: StackInterpreterSimulator>>signalSemaphoreWithIndex: (in category 'process primitive support') -----
  signalSemaphoreWithIndex: index
+ "This is a simulation.  See platforms/Cross/vm/sqExternalSemaphores.c for the real code.
+ Thanks to Levente Uzoni for making this version almost thread-safe (in Smalltalk)"
+ <doNotGenerate>
+ | originalResponses newRequests newResponses |
- "This is a non-thread-safe simulation.  See platforms/Cross/vm/sqExternalSemaphores.c
- for the real code."
  index <= 0 ifTrue: [^false].
  index > externalSemaphoreSignalRequests size ifTrue:
+ [newRequests := Array new: 1 << index highBit withAll: 0.
+ newResponses := newRequests shallowCopy].
+ "This is a lock-free thread-safe grow...; thanks Levente"
+ originalResponses := externalSemaphoreSignalResponses.
+ [index > externalSemaphoreSignalRequests size] whileTrue:
+ [newRequests
- [| newRequests newResponses |
- newRequests := Array new: 1 << index highBit withAll: 0.
- newResponses := newRequests copy.
- newRequests
  replaceFrom: 1
  to: externalSemaphoreSignalRequests size
  with: externalSemaphoreSignalRequests
  startingAt: 1.
+ newResponses
- newResponses
  replaceFrom: 1
  to: externalSemaphoreSignalResponses size
  with: externalSemaphoreSignalResponses
  startingAt: 1.
+ externalSemaphoreSignalResponses == originalResponses "This should always be true."
+ ifTrue:
+ [externalSemaphoreSignalRequests := newRequests.
+ externalSemaphoreSignalResponses := newResponses]
+ ifFalse:
+ [originalResponses := externalSemaphoreSignalResponses]].
+ "This is not thread-safe however..."
- externalSemaphoreSignalRequests := newRequests.
- externalSemaphoreSignalResponses := newResponses].
  externalSemaphoreSignalRequests
  at: index
  put: (externalSemaphoreSignalRequests at: index) + 1.
  ^true!

Loading...