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

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

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

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

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

Name: VMMaker.oscogSPC-eem.2112
Author: eem
Time: 25 January 2017, 1:00:46.35451 pm
UUID: 2cb05138-53ee-44f4-9ef2-687f081b72d6
Ancestors: VMMaker.oscogSPC-eem.2109, VMMaker.oscog-eem.2111

Temporary branch for SpurPlanningCompactor as default compactor. Otherwise the same as VMMaker.oscog-eem.2111

Eliminate several signed comparisons in SpurPlanningCompactor.  Add a class side analyser that spots them.

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

Item was changed:
  ----- Method: CCodeGenerator>>returnTypeForSend:in:ifNil: (in category 'type inference') -----
  returnTypeForSend: sendNode in: aTMethod ifNil: typeIfNil
  "Answer the return type for a send.  Unbound sends default to typeIfNil.
  Methods with types as yet unknown have a type determined either by the
  kernelReturnTypes or the table below, or, if they are in neither set, then nil.
  The inferred type should match as closely as possible the C type of
  generated expessions so that inlining would not change the expression.
  If there is a method for sel but its return type is as yet unknown it mustn't
  be defaulted, since on a subsequent pass its type may be computable."
  | sel methodOrNil |
  methodOrNil := self anyMethodNamed: (sel := sendNode selector).
  (methodOrNil notNil and: [methodOrNil returnType notNil]) ifTrue:
  [^self baseTypeForType: methodOrNil returnType].
  ^kernelReturnTypes
  at: sel
  ifAbsent:
  [sel
  caseOf: {
  [#integerValueOf:] -> [#sqInt].
  [#isIntegerObject:] -> [#int].
  [#negated] -> [self promoteArithmeticTypes: (self typeFor: sendNode receiver in: aTMethod) and: #int].
  [#+] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#-] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#*] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#/] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#//] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#\\] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#rem:] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#quo:] -> [self typeForArithmetic: sendNode in: aTMethod].
  "C99 Sec Bitwise shift operators ... 3 Sematics ...
  The integer promotions are performed on each of the operands. The type of the result is that of the promoted left operand..."
  [#>>] -> [self typeFor: sendNode receiver in: aTMethod].
  [#<<] -> [self typeFor: sendNode receiver in: aTMethod].
  [#addressOf:] -> [(self typeFor: sendNode receiver in: aTMethod)
  ifNil: [#sqInt]
  ifNotNil: [:type| type, (type last isLetter ifTrue: [' *'] ifFalse: ['*'])]].
  [#at:] -> [self typeForDereference: sendNode in: aTMethod].
  [#bitAnd:] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#bitOr:] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#bitXor:] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#bitClear:] -> [self typeForArithmetic: sendNode in: aTMethod].
  [#bitInvert32] -> [#'unsigned int'].
  [#bitInvert64] -> [self promoteArithmeticTypes: (self typeFor: sendNode receiver in: aTMethod) and: #int].
  [#byteSwap32] -> [#'unsigned int'].
  [#byteSwap64] -> [#'unsigned long long'].
  [#byteSwapped32IfBigEndian:] -> [#'unsigned int'].
  [#byteSwapped64IfBigEndian:] -> [#'unsigned long long'].
  [#=] -> [#int].
  [#~=] -> [#int].
  [#==] -> [#int].
  [#~~] -> [#int].
  [#<] -> [#int].
  [#<=] -> [#int].
  [#>] -> [#int].
  [#>=] -> [#int].
  [#between:and:] -> [#int].
  [#anyMask:] -> [#int].
  [#allMask:] -> [#int].
  [#noMask:] -> [#int].
  [#isNil] -> [#int].
  [#notNil] -> [#int].
  [#&] -> [#int].
  [#|] -> [#int].
  [#not] -> [#int].
  [#asFloat] -> [#double].
  [#atan] -> [#double].
  [#exp] -> [#double].
  [#log] -> [#double].
  [#sin] -> [#double].
  [#sqrt] -> [#double].
  [#asLong] -> [#long].
  [#asInteger] -> [#sqInt].
  [#asIntegerPtr] -> [#'sqIntptr_t'].
  [#asUnsignedInteger] -> [#usqInt].
  [#asUnsignedIntegerPtr]-> [#'usqIntptr_t'].
  [#asUnsignedLong] -> [#'unsigned long'].
  [#asUnsignedLongLong] -> [#'unsigned long long'].
  [#asVoidPointer] -> [#'void *'].
  [#signedIntToLong] -> [#usqInt]. "c.f. generateSignedIntToLong:on:indent:"
  [#signedIntToShort] -> [#usqInt]. "c.f. generateSignedIntToShort:on:indent:"
  [#cCoerce:to:] -> [sendNode args last value].
  [#cCoerceSimple:to:] -> [sendNode args last value].
  [#sizeof:] -> [#'usqIntptr_t']. "Technically it's a size_t but it matches on target architectures so far..."
  [#ifTrue:ifFalse:] -> [self typeForConditional: sendNode in: aTMethod].
  [#ifFalse:ifTrue:] -> [self typeForConditional: sendNode in: aTMethod].
  [#ifTrue:] -> [self typeForConditional: sendNode in: aTMethod].
  [#ifFalse:] -> [self typeForConditional: sendNode in: aTMethod].
  [#and:] -> [#sqInt].
+ [#or:] -> [#sqInt].
+ [#caseOf:] -> [self typeFor: sendNode args first in: aTMethod] }
- [#or:] -> [#sqInt] }
  otherwise: "If there /is/ a method for sel but its return type is as yet unknown it /mustn't/ be defaulted,
  since on a subsequent pass its type may be computable.  Only default unbound selectors."
  [methodOrNil ifNotNil: [nil] ifNil: [typeIfNil]]]!

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>>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:
  [(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 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>>findNextMarkedPinnedAfter: (in category 'private') -----
  findNextMarkedPinnedAfter: unpinnedObj
  <inline: true>
  | nextObj |
  self deny: ((manager isPinned: unpinnedObj) and: [manager isMarked: unpinnedObj]).
  nextObj := unpinnedObj.
  [nextObj := manager objectAfter: nextObj limit: manager endOfMemory.
+ (self oop: nextObj isGreaterThanOrEqualTo: manager endOfMemory) ifTrue:
- 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>>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>>logPhase: (in category 'private') -----
  logPhase: phaseName
  <inline: true>
+ self break.
+ self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: phaseName; flush]. !
- self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: phaseName; flush].!

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 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 objectAfter: nextObj limit: manager endOfMemory.
+ (self oop: nextObj isGreaterThanOrEqualTo: manager endOfMemory) ifTrue:
- 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 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>>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: StackInterpreter>>printDecodeMethodHeaderOop: (in category 'printing') -----
  printDecodeMethodHeaderOop: methodHeaderOop
  self printOopShort: methodHeaderOop.
  (self methodHeaderHasPrimitive: methodHeaderOop) ifTrue:
  [self print: ' hasPrim'].
  (self methodHeaderIndicatesLargeFrame: methodHeaderOop) ifTrue:
  [self print: ' largeFrame'].
  (SistaVM and: [self isOptimizedMethodHeader: methodHeaderOop]) ifTrue:
  [self print: ' optimized'].
  (MULTIPLEBYTECODESETS and: [objectMemory integerValueOf: methodHeaderOop]) < 0 ifTrue:
  [self print: ' altSet'].
  NewspeakVM ifTrue:
+ [| s |
+ s := (self accessModifierOfMethodHeader: methodHeaderOop) caseOf: {
- [self print: ((self accessModifierOfMethodHeader: methodHeaderOop) caseOf: {
  [0] -> [' public'].
  [1] -> [' private'].
  [2] -> [' protected'].
+ [3] -> [' access undefined'] }.
+ self print: s].
- [3] -> [' access undefined'] })].
  self print: ' nLits '; printNum: (objectMemory literalCountOfMethodHeader: methodHeaderOop);
  print: ' nArgs '; printNum: (self argumentCountOfMethodHeader: methodHeaderOop);
  print: ' nTemps '; printNum: (self temporaryCountOfMethodHeader: methodHeaderOop)!

Item was added:
+ ----- Method: TBraceCaseNode>>typeOrNilFrom:in: (in category 'type inference') -----
+ typeOrNilFrom: aCodeGenerator in: aTMethod
+ | types |
+ types := Set withAll: (cases collect: [:case| case typeOrNilFrom: aCodeGenerator in: aTMethod]).
+ ^types size = 1 ifTrue: [types anyOne]!

Item was changed:
  ----- Method: TConstantNode>>typeOrNilFrom:in: (in category 'type inference') -----
  typeOrNilFrom: aCodeGenerator in: aTMethod
  "For integers, answer int unless the value does not fit into a 32bits signed int.
  In that case, answer the shortest architecture independant integer type that could hold the constant.
  This method must be consistent with CCodeGenerator>>cLiteralFor:"
  | hb |
  value isInteger
  ifTrue:
  [value positive
  ifTrue:
  [hb := value highBit.
  hb < 32 ifTrue: [^#int].
  hb = 32 ifTrue: [^#'unsigned int'].
  hb = 64 ifTrue: [^#'unsigned long long'].
  ^#'long long']
  ifFalse:
  [hb := value bitInvert highBit.
  hb < 32 ifTrue: [^#int].
  ^#'long long']].
  value isFloat ifTrue: [^#double].
  (#(nil true false) includes: value) ifTrue: [^#int].
+ (value isString and: [value isSymbol not]) ifTrue: [^#'char *'].
  ^nil!

Item was changed:
  ----- Method: TSendNode>>emitCCodeAsFunctionCallOn:level:generator: (in category 'C code generation') -----
  emitCCodeAsFunctionCallOn: aStream level: level generator: aCodeGen
-
  "Translate this message send into a C function call"
+
+ selector == #break ifTrue:
+ [aStream nextPutAll: '/* send of break elided */'.
+ ^self].
+
  "Special case for pluggable modules. Replace messages to interpreterProxy
  by interpreterProxy->message(..) if the message is not builtin"
  (aCodeGen shouldGenerateAsInterpreterProxySend: self) ifTrue:
  [(aCodeGen noteUsedPluginFunction: selector) ifTrue:
  [aStream nextPutAll: 'interpreterProxy->']].
 
- "Translate this message send into a C function call."
  aStream nextPutAll: (aCodeGen cFunctionNameFor: selector); nextPut: $(.
+
  "Only include the receiver as the first argument in certain cases.
  The receiver is always included if it is an expression.
  If it is a variable:
  If the vmClass says it is an implicit variable, don't include it.
  If the variable is 'self' and the method being called is not in
  the method set (i.e. it is some external code), don't include it."
  (self shouldExcludeReceiverAsFirstArgument: aCodeGen) ifFalse:
  [(receiver structTargetKindIn: aCodeGen) == #struct ifTrue:
  [aStream nextPut: $&].
  receiver emitCCodeOn: aStream level: level generator: aCodeGen.
  arguments isEmpty ifFalse:
  [aStream nextPutAll: ', ']].
  arguments
  do: [ :arg| arg emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen]
  separatedBy: [aStream nextPut: $,; space].
  aStream nextPut: $)!

Item was changed:
  ----- Method: TSwitchStmtNode>>emitCCodeOn:addToEndOfCases:level:generator: (in category 'C code generation') -----
  emitCCodeOn: aStream addToEndOfCases: aNodeOrNil level: level generator: aCodeGen
 
  aStream crtab: level.
  aStream nextPutAll: 'switch ('.
  expression emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen.
  aStream nextPutAll: ') {'.
  cases do:
  [:tuple|
  [:labels :case|
   labels do:
  [:label|
  aStream
  crtab: level;
  nextPutAll: 'case '.
  label emitCCodeAsArgumentOn: aStream level: level + 1 generator: aCodeGen.
  aStream nextPut: $:].
   aStream crtab: level + 1.
   case emitCCodeOn: aStream prependToEnd: aNodeOrNil level: level + 1 generator: aCodeGen]
  valueWithArguments: tuple.
   (aNodeOrNil notNil and: [aNodeOrNil isReturn]) ifFalse:
  [aStream crtab: level + 1; nextPutAll: 'break;']].
  aStream
  crtab: level;
  nextPutAll: 'default:';
  crtab: level + 1.
  otherwiseOrNil
  ifNotNil: [otherwiseOrNil emitCCodeOn: aStream prependToEnd: aNodeOrNil level: level + 1 generator: aCodeGen]
  ifNil: [aStream nextPutAll: 'error("Case not found and no otherwise clause");'.
    aNodeOrNil ifNotNil:
+ [| defaultExpr type |
+ aStream crtab: level + 1.
+ defaultExpr := TConstantNode new setValue: -1.
+ (aNodeOrNil isAssignment
+  and: [(type := aCodeGen typeFor: aNodeOrNil variable in: aCodeGen currentMethod) notNil
+  and: [aCodeGen isPointerCType: type]]) ifTrue:
+ [defaultExpr := TSendNode new
+ setSelector: #cCoerceSimple:to:
+ receiver: (TVariableNode new setName: 'self')
+ arguments: {defaultExpr. TConstantNode new setValue: type}].
+ (aNodeOrNil copy setExpression: defaultExpr)
- [aStream crtab: level + 1.
- (aNodeOrNil copy setExpression: (TConstantNode new setValue: -1))
  emitCCodeOn: aStream level: level generator: aCodeGen.
  aStream nextPut: $;]].
  aStream
  crtab: level;
  nextPut: $}!