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

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

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

Name: VMMaker.oscog-eem.123
Author: eem
Time: 6 September 2011, 4:36:50.618 pm
UUID: 9c524903-b0c7-46a8-a37a-5dfda6fcd1f3
Ancestors: VMMaker.oscog-eem.122

Cog:
Refactor, moving isContextNonInt:, instSpecOfClass:
and sufficientSpaceToInstantiate:indexableSize: to ObjectMemory.
Fix the 1Gb allocation bug,
Use formatOfHeader: instead of raw foo >> 8 bitAnd: 15.
Fix gcc compiler warnings in getStackPointer and printOop.

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

Item was changed:
  ----- Method: CoInterpreter>>ceContext:instVar: (in category 'trampolines') -----
  ceContext: maybeContext instVar: slotIndex
  <api>
  | result |
+ (objectMemory isContextNonInt: maybeContext)
- (self isContextNonInt: maybeContext)
  ifTrue:
  [instructionPointer := self popStack.
  result := self externalInstVar: slotIndex ofContext: maybeContext.
  self push: instructionPointer]
  ifFalse: [result := objectMemory fetchPointer: slotIndex ofObject: maybeContext].
  ^result!

Item was changed:
  ----- Method: CoInterpreter>>ceContext:instVar:value: (in category 'trampolines') -----
  ceContext: maybeMarriedContext instVar: slotIndex value: anOop
  <api>
  "genStorePop:MaybeContextReceiverVariable: filters out unmarried contexts
  but not arbitrary objects in subclasses.  It answers maybeMarriedContext so
  that the StackToRegisterMappingCogit can keep ReceiverResultReg live."
+ (objectMemory isContextNonInt: maybeMarriedContext)
- (self isContextNonInt: maybeMarriedContext)
  ifTrue:
  [self assert: (self isMarriedOrWidowedContext: maybeMarriedContext).
  instructionPointer := self popStack.
  self externalInstVar: slotIndex ofContext: maybeMarriedContext put: anOop.
  self push: instructionPointer]
  ifFalse:
  [objectMemory storePointer: slotIndex ofObject: maybeMarriedContext withValue: anOop].
  ^maybeMarriedContext!

Item was changed:
  ----- Method: CoInterpreter>>ensureAllContextsHaveBytecodePCsOrAreBereaved (in category 'frame access') -----
  ensureAllContextsHaveBytecodePCsOrAreBereaved
  "Enumerate all contexts preparing them for a snapshot.  Map all native pcs to bytecoded pcs.
  Convert widowed contexts to single contexts so that the snapshot contains only single contexts.
  This allows the being married test to avoid checking for a context's frame pointer being in bounds
  since all frame pointers must have been created in the current system and so be in bounds.
  Thanks to Greg Nuyens for this idea."
  | oop decodedIP |
  oop := objectMemory firstObject.
  [oop < objectMemory freeStart] whileTrue:
  [((objectMemory isFreeObject: oop) not
+   and: [objectMemory isContextNonInt: oop]) ifTrue:
-   and: [self isContextNonInt: oop]) ifTrue:
  [(self isMarriedOrWidowedContext: oop)
  ifTrue: "The stack pages have already been discarded.  Any remaining married contexts are actually widows."
  [self markContextAsDead: oop]
  ifFalse:
  [decodedIP := objectMemory fetchPointer: InstructionPointerIndex ofObject: oop.
  ((objectMemory isIntegerObject: decodedIP)
  and: [decodedIP signedIntFromLong < 0]) ifTrue:
  [decodedIP := self mustMapMachineCodePC: (objectMemory integerValueOf: decodedIP)
  context: oop.
  objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: oop withValue: decodedIP]]].
  oop := objectMemory objectAfter: oop]!

Item was removed:
- ----- Method: Interpreter>>isContextNonInt: (in category 'contexts') -----
- isContextNonInt: oop
- <inline: true>
- ^self isContextHeader: (self baseHeader: oop)!

Item was removed:
- ----- Method: Interpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') -----
- sufficientSpaceToInstantiate: classOop indexableSize: size
- "Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields."
- "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
- | format atomSize|
- <inline: true>
- format := (self formatOfClass: classOop) >> 8 bitAnd: 15.
-
- "fail if attempting to call new: on non-indexable class"
- ((self cCoerce: size to: 'usqInt ') > 0 and: [format < 2])
- ifTrue: [^ false].
-
- format < 8
- ifTrue: ["indexable fields are words or pointers" atomSize := BytesPerWord]
- ifFalse: ["indexable fields are bytes" atomSize := 1].
- ^self sufficientSpaceToAllocate: 2500 + (size * atomSize)!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveNew (in category 'object access primitives') -----
  primitiveNew
  "Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. May cause a GC"
 
  | class spaceOkay |
  class := self stackTop.
  "The following may cause GC!!"
+ spaceOkay := objectMemory sufficientSpaceToInstantiate: class indexableSize: 0.
- spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: 0.
  self success: spaceOkay.
+ self successful ifTrue:
+ [self push: (objectMemory instantiateClass: self popStack indexableSize: 0)]!
- self successful ifTrue: [ self push: (objectMemory instantiateClass: self popStack indexableSize: 0) ]!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveNewWithArg (in category 'object access primitives') -----
  primitiveNewWithArg
  "Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free."
  | size class spaceOkay |
  size := self positive32BitValueOf: self stackTop.
  class := self stackValue: 1.
  self success: size >= 0.
+ self successful ifTrue:
+ ["The following may cause GC!!"
+ spaceOkay := objectMemory sufficientSpaceToInstantiate: class indexableSize: size.
+ self success: spaceOkay.
+ class := self stackValue: 1].
+ self successful ifTrue:
+ [self pop: 2 thenPush: (objectMemory instantiateClass: class indexableSize: size)]!
- self successful
- ifTrue: ["The following may cause GC!!"
- spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: size.
- self success: spaceOkay.
- class := self stackValue: 1].
- self successful ifTrue: [self pop: 2 thenPush: (objectMemory instantiateClass: class indexableSize: size)]!

Item was changed:
  ----- Method: NewObjectMemory>>eeInstantiateAndInitializeClass:indexableSize: (in category 'interpreter access') -----
  eeInstantiateAndInitializeClass: classPointer indexableSize: size
  "NOTE: This method supports the backward-compatible split instSize field of the
  class format word. The sizeHiBits will go away and other shifts change by 2
  when the split fields get merged in an (incompatible) image change.
  Will *not* cause a GC.  The instantiated object is initialized."
 
  | hash header1 header2 cClass byteSize format binc header3 hdrSize sizeHiBits bm1 classFormat |
  <inline: false>
  "cannot have a negative indexable field count"
  self assert: size >= 0.
  hash := self newObjectHash.
  classFormat := self formatOfClass: classPointer.
  "Low 2 bits are 0"
  header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset.
  header2 := classPointer.
  header3 := 0.
  sizeHiBits := (classFormat bitAnd: 16r60000) >> 9.
  cClass := header1 bitAnd: CompactClassMask. "compact class field from format word"
  byteSize := (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits.
  "size in bytes -- low 2 bits are 0"
  "Note this byteSize comes from the format word of the class which is pre-shifted
  to 4 bytes per field.  Need another shift for 8 bytes per word..."
  byteSize := byteSize << (ShiftForWord-2).
+ format := self formatOfHeader: classFormat.
- format := classFormat >> 8 bitAnd: 15.
  self flag: #sizeLowBits.
  format < 8
  ifTrue:
  [format = 6
  ifTrue: ["long32 bitmaps"
  bm1 := BytesPerWord-1.
  byteSize := byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up"
  binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes"
  "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
  header1 := header1 bitOr: (binc bitAnd: 4)]
  ifFalse: [byteSize := byteSize + (size * BytesPerWord) "Arrays and 64-bit bitmaps"]
  ]
  ifFalse:
  ["Strings and Methods"
  bm1 := BytesPerWord-1.
  byteSize := byteSize + size + bm1 bitAnd: LongSizeMask. "round up"
  binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes"
  "low bits of byte size go in format field"
  header1 := header1 bitOr: (binc bitAnd: 3) << 8.
  "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
  header1 := header1 bitOr: (binc bitAnd: 4)].
  byteSize > 255
  ifTrue: ["requires size header word"
  header3 := byteSize.
  header1 := header1]
  ifFalse: [header1 := header1 bitOr: byteSize].
  header3 > 0
  ifTrue: ["requires full header"
  hdrSize := 3]
  ifFalse: [cClass = 0
  ifTrue: [hdrSize := 2]
  ifFalse: [hdrSize := 1]].
  ^self eeAllocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true format: format!

Item was changed:
  ----- Method: NewObjectMemory>>eeInstantiateClass:indexableSize: (in category 'interpreter access') -----
  eeInstantiateClass: classPointer indexableSize: size
  "NOTE: This method supports the backward-compatible split instSize field of the
  class format word. The sizeHiBits will go away and other shifts change by 2
  when the split fields get merged in an (incompatible) image change.
  Will *not* cause a GC.
  Note that the instantiated object IS NOT FILLED and must be completed before
  returning it to Smalltalk. Since this call is used in routines that do just that we are
  safe.  Break this rule and die."
  <api>
  | hash header1 header2 cClass byteSize format binc header3 hdrSize sizeHiBits bm1 classFormat |
  <inline: false>
  "cannot have a negative indexable field count"
  self assert: size >= 0.
  hash := self newObjectHash.
  classFormat := self formatOfClass: classPointer.
  "Low 2 bits are 0"
  header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset.
  header2 := classPointer.
  header3 := 0.
  sizeHiBits := (classFormat bitAnd: 16r60000) >> 9.
  cClass := header1 bitAnd: CompactClassMask. "compact class field from format word"
  byteSize := (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits.
  "size in bytes -- low 2 bits are 0"
  "Note this byteSize comes from the format word of the class which is pre-shifted
  to 4 bytes per field.  Need another shift for 8 bytes per word..."
  byteSize := byteSize << (ShiftForWord-2).
+ format := self formatOfHeader: classFormat.
- format := classFormat >> 8 bitAnd: 15.
  self flag: #sizeLowBits.
  format < 8
  ifTrue:
  [format = 6
  ifTrue: ["long32 bitmaps"
  bm1 := BytesPerWord-1.
  byteSize := byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up"
  binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes"
  "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
  header1 := header1 bitOr: (binc bitAnd: 4)]
  ifFalse: [byteSize := byteSize + (size * BytesPerWord) "Arrays and 64-bit bitmaps"]
  ]
  ifFalse:
  ["Strings and Methods"
  bm1 := BytesPerWord-1.
  byteSize := byteSize + size + bm1 bitAnd: LongSizeMask. "round up"
  binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes"
  "low bits of byte size go in format field"
  header1 := header1 bitOr: (binc bitAnd: 3) << 8.
  "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
  header1 := header1 bitOr: (binc bitAnd: 4)].
  byteSize > 255
  ifTrue: ["requires size header word"
  header3 := byteSize.
  header1 := header1]
  ifFalse: [header1 := header1 bitOr: byteSize].
  header3 > 0
  ifTrue: ["requires full header"
  hdrSize := 3]
  ifFalse: [cClass = 0
  ifTrue: [hdrSize := 2]
  ifFalse: [hdrSize := 1]].
  ^self eeAllocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3!

Item was removed:
- ----- Method: NewspeakInterpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') -----
- sufficientSpaceToInstantiate: classOop indexableSize: size
- "Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields."
- "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
- | format atomSize|
- <inline: true>
- format := (self formatOfClass: classOop) >> 8 bitAnd: 15.
-
- "fail if attempting to call new: on non-indexable class"
- ((self cCoerce: size to: 'usqInt ') > 0 and: [format < 2])
- ifTrue: [^ false].
-
- format < 8
- ifTrue: ["indexable fields are words or pointers" atomSize := BytesPerWord]
- ifFalse: ["indexable fields are bytes" atomSize := 1].
- ^self sufficientSpaceToAllocate: 2500 + (size * atomSize)!

Item was changed:
  VMClass subclass: #ObjectMemory
  instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statIncrGCs statFullGCUsecs statIncrGCUsecs statGCEndTime statIGCDeltaUsecs statTenures statRootTableOverflows freeContexts freeLargeContexts interruptCheckCounter totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statMarkCountLocal statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statSpecialMarkCount forceTenureFlag gcStartUsecs'
+ classVariableNames: 'AllButHashBits AllButImmutabilityBit AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit Done ExtraRootSize GCTopMarker HashBits HeaderTypeClass HeaderTypeExtraBytes HeaderTypeFree HeaderTypeGC LongSizeNumBits NilContext RemapBufferSize RootTableRedZone RootTableSize StartField StartObj Upward WeakRootTableSize WordMask'
- classVariableNames: 'AllButHashBits AllButImmutabilityBit AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit Done ExtraRootSize GCTopMarker HashBits HeaderTypeClass HeaderTypeExtraBytes HeaderTypeFree HeaderTypeGC NilContext RemapBufferSize RootTableRedZone RootTableSize StartField StartObj Upward WeakRootTableSize WordMask'
  poolDictionaries: 'VMBasicConstants VMObjectIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants'
  category: 'VMMaker-Interpreter'!
 
  !ObjectMemory commentStamp: '<historical>' prior: 0!
  This class describes a 32-bit direct-pointer object memory for Smalltalk.  The model is very simple in principle:  a pointer is either a SmallInteger or a 32-bit direct object pointer.
 
  SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word.
 
  All object pointers point to a header, which may be followed by a number of data fields.  This object memory achieves considerable compactness by using a variable header size (the one complexity of the design).  The format of the 0th header word is as follows:
 
  3 bits reserved for gc (mark, root, unused)
  12 bits object hash (for HashSets)
  5 bits compact class index
  4 bits object format
  6 bits object size in 32-bit words
  2 bits header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word)
 
  If a class is in the compact class table, then this is the only header information needed.  If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits.  It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits.
 
  The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects).
 
  This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers.  It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk.
 
  There is now a simple 64-bit version of the object memory.  It is the simplest possible change that could work.  It merely sign-extends all integer oops, and extends all object headers and oops by adding 32 zeroes in the high bits.  The format of the base header word is changed in one minor, not especially elegant, way.  Consider the old 32-bit header:
  ggghhhhhhhhhhhhcccccffffsssssstt
  The 64-bit header is almost identical, except that the size field (now being in units of 8 bytes, has a zero in its low-order bit.  At the same time, the byte-size residue bits for byte objects, which are in the low order bits of formats 8-11 and 12-15, are now in need of another bit of residue.  So, the change is as follows:
  ggghhhhhhhhhhhhcccccffffsssssrtt
  where bit r supplies the 4's bit of the byte size residue for byte objects.  Oh, yes, this is also needed now for 'variableWord' objects, since their size in 32-bit words requires a low-order bit.
 
  See the comment in formatOf: for the change allowing for 64-bit wide bitmaps, now dubbed 'variableLong'.!

Item was changed:
  ----- Method: ObjectMemory class>>initializeObjectHeaderConstants (in category 'initialization') -----
  initializeObjectHeaderConstants
 
  BytesPerWord ifNil: [BytesPerWord := 4].  "May get called on fileIn, so supply default"
  BaseHeaderSize := BytesPerWord.
  WordMask := (1 bitShift: BytesPerWord*8) - 1.
 
  "masks for type field"
  TypeMask := 3.
  AllButTypeMask := WordMask - TypeMask.
 
  "type field values"
  HeaderTypeSizeAndClass := 0.
  HeaderTypeClass := 1.
  HeaderTypeFree := 2.
  HeaderTypeShort := 3.
  HeaderTypeExtraBytes := { BytesPerWord * 2. BytesPerWord. 0. 0 }.
 
  "type field values used during the mark phase of GC"
  HeaderTypeGC := 2.
  GCTopMarker := 3.  "neither an oop, nor an oop+1, this value signals that we have crawled back up to the top of the marking phase."
 
  "Base header word bit fields"
  HashBits := 16r1FFE0000.
  HashBitsOffset := 17.
  HashMaskUnshifted := 16rFFF.
  self assert: (HashMaskUnshifted bitShift: HashBitsOffset) = HashBits.
  AllButHashBits := WordMask - HashBits.
  SizeMask := 16rFC.
  Size4Bit := 0.
  BytesPerWord = 8 ifTrue:
  [SizeMask := 16rF8.  "Lose the 4 bit in temp 64-bit chunk format"
  Size4Bit := 4].  "But need it for ST size"
  "Note SizeMask + Size4Bit gives the mask needed for size fits of format word in classes.
  This is used in instantiateClass:indexableSize: "
  LongSizeMask := WordMask - 16rFF + SizeMask.
+ LongSizeNumBits := 30. "30 bits of size info in long size filed."
  CompactClassMask := 16r1F000.
 
  "masks for root and mark bits"
  MarkBit := 1 bitShift: BytesPerWord*8 - 1.  "Top bit"
  RootBit := 1 bitShift: BytesPerWord*8 - 2.  "Next-to-Top bit"
  AllButMarkBit := WordMask - MarkBit.
  AllButRootBit := WordMask - RootBit.
 
  AllButMarkBitAndTypeMask := AllButTypeMask - MarkBit.
 
  ImmutabilityBit := 1 bitShift: BytesPerWord*8 - 3.  "Next-to-Next-To-Top bit"
  AllButImmutabilityBit := WordMask - ImmutabilityBit!

Item was added:
+ ----- Method: ObjectMemory>>instSpecOfClass: (in category 'object format') -----
+ instSpecOfClass: classPointer
+ "This is the same as the field stored in every object header"
+
+ ^self formatOfHeader: (self formatOfClass: classPointer)!

Item was changed:
  ----- Method: ObjectMemory>>instantiateClass:indexableSize: (in category 'interpreter access') -----
  instantiateClass: classPointer indexableSize: size
  "NOTE: This method supports the backward-compatible split instSize field of the
  class format word. The sizeHiBits will go away and other shifts change by 2
  when the split fields get merged in an (incompatible) image change."
  <api>
  | hash header1 header2 cClass byteSize format binc header3 hdrSize newObj sizeHiBits bm1 classFormat |
  <inline: false>
  self assert: size >= 0. "'cannot have a negative indexable field count"
  hash := self newObjectHash.
  classFormat := self formatOfClass: classPointer.
  "Low 2 bits are 0"
  header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset.
  header2 := classPointer.
  header3 := 0.
  sizeHiBits := (classFormat bitAnd: 16r60000) >> 9.
  cClass := header1 bitAnd: CompactClassMask. "compact class field from format word"
  byteSize := (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits.
  "size in bytes -- low 2 bits are 0"
  "Note this byteSize comes from the format word of the class which is pre-shifted
  to 4 bytes per field.  Need another shift for 8 bytes per word..."
  byteSize := byteSize << (ShiftForWord-2).
+ format := self formatOfHeader: classFormat.
- format := classFormat >> 8 bitAnd: 15.
  self flag: #sizeLowBits.
  format < 8
  ifTrue:
  [format = 6
  ifTrue: ["long32 bitmaps"
  bm1 := BytesPerWord-1.
  byteSize := byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up"
  binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes"
  "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
  header1 := header1 bitOr: (binc bitAnd: 4)]
  ifFalse: [byteSize := byteSize + (size * BytesPerWord) "Arrays and 64-bit bitmaps"]]
  ifFalse:
  ["Strings and Methods"
  bm1 := BytesPerWord-1.
  byteSize := byteSize + size + bm1 bitAnd: LongSizeMask. "round up"
  binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes"
  "low bits of byte size go in format field"
  header1 := header1 bitOr: (binc bitAnd: 3) << 8.
  "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
  header1 := header1 bitOr: (binc bitAnd: 4)].
  byteSize > 255
  ifTrue: ["requires size header word"
  header3 := byteSize.
  header1 := header1]
  ifFalse: [header1 := header1 bitOr: byteSize].
 
  hdrSize := header3 > 0
  ifTrue: [3 "requires full header"]
  ifFalse: [cClass = 0 ifTrue: [2] ifFalse: [1]].
  newObj := self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true format: format.
  ^ newObj!

Item was added:
+ ----- Method: ObjectMemory>>isContextNonInt: (in category 'contexts') -----
+ isContextNonInt: oop
+ <inline: true>
+ ^self isContextHeader: (self baseHeader: oop)!

Item was changed:
  ----- Method: ObjectMemory>>shorten:toIndexableSize: (in category 'allocation') -----
  shorten: obj toIndexableSize: nSlots
  "Currently this works for pointer objects only, and is almost certainly wrong for 64 bits."
  | deltaBytes desiredLength fixedFields fmt hdr totalLength |
  (self isPointers: obj) ifFalse:
  [^obj].
  hdr := self baseHeader: obj.
+ fmt := self formatOfHeader: hdr.
- fmt := (hdr >> 8) bitAnd: 16rF.
  totalLength := self lengthOf: obj baseHeader: hdr format: fmt.
  fixedFields := self fixedFieldsOf: obj format: fmt length: totalLength.
  desiredLength := fixedFields + nSlots.
  deltaBytes := (totalLength - desiredLength) * BytesPerWord.
  self setSizeOfFree: obj + BaseHeaderSize + (desiredLength * BytesPerWord)
  to: deltaBytes.
  (self headerType: obj) caseOf: {
  [HeaderTypeSizeAndClass] ->
  [self longAt: obj put: hdr - deltaBytes].
  [HeaderTypeClass] ->
  [self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)].
  [HeaderTypeShort] ->
  [self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)] }.
  ^obj!

Item was added:
+ ----- Method: ObjectMemory>>sufficientSpaceToInstantiate:indexableSize: (in category 'allocation') -----
+ sufficientSpaceToInstantiate: classOop indexableSize: size
+ "Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields."
+ "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
+ <var: #size type: #usqInt>
+ | format allocSize |
+ <inline: true>
+ (format := self instSpecOfClass: classOop) < 8
+ ifTrue:
+ ["indexable fields are words or pointers"
+ size ~= 0 ifTrue:
+ ["fail if attempting to call new: on non-indexable class"
+ format < 2 ifTrue:
+ [^false].
+ "fail if attempting to allocate over 2 Gb, since this overflows 32-bit arithmetic"
+ size >> (LongSizeNumBits - BytesPerWord) > 0 ifTrue:
+ [^false]].
+ allocSize := size * BytesPerWord]
+ ifFalse:
+ ["indexable fields are bytes"
+ "fail if attempting to allocate over 2 Gb, since this overflows 32-bit arithmetic"
+ size >> LongSizeNumBits > 0 ifTrue:
+ [^false].
+ allocSize := size].
+ ^self sufficientSpaceToAllocate: 2500 + allocSize!

Item was changed:
  ----- Method: StackInterpreter>>bereaveAllMarriedContexts (in category 'frame access') -----
  bereaveAllMarriedContexts
  "Enumerate all contexts and convert married contexts to widowed contexts so
  that the snapshot contains only single contexts.  This allows the test for being
  married to avoid checking for a context's frame pointer being in bounds.
  Thanks to Greg Nuyens for this idea."
  | oop |
  <asmLabel: false>
  oop := objectMemory firstObject.
  [oop < objectMemory freeStart] whileTrue:
  [((objectMemory isFreeObject: oop) not
+   and: [(objectMemory isContextNonInt: oop)
-   and: [(self isContextNonInt: oop)
    and: [self isMarriedOrWidowedContext: oop]]) ifTrue:
  [self markContextAsDead: oop].
  oop := objectMemory objectAfter: oop]!

Item was changed:
  ----- Method: StackInterpreter>>getStackPointer (in category 'primitive support') -----
  getStackPointer
  "For Alien FFI"
  <api>
  <returnTypeC: #'sqInt *'>
+ ^self cCoerceSimple: stackPointer to: #'sqInt *'!
- ^stackPointer!

Item was removed:
- ----- Method: StackInterpreter>>instSpecOfClass: (in category 'object format') -----
- instSpecOfClass: classPointer
- "This is the same as the field stored in every object header"
-
- ^(objectMemory formatOfClass: classPointer) >> 8 bitAnd: 16rF!

Item was removed:
- ----- Method: StackInterpreter>>isContextNonInt: (in category 'internal interpreter access') -----
- isContextNonInt: oop
- <inline: true>
- ^objectMemory isContextHeader: (objectMemory baseHeader: oop)!

Item was changed:
  ----- Method: StackInterpreter>>printOop: (in category 'debug printing') -----
  printOop: oop
  | cls fmt lastIndex startIP bytecodesPerLine |
  <inline: false>
  self printHex: oop.
  (objectMemory isIntegerObject: oop) ifTrue:
  [^self
  cCode: 'printf("=%ld\n", integerValueOf(oop))'
  inSmalltalk: [self print: (self shortPrint: oop); cr]].
  (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
  [self printHex: oop; print: ' is not on the heap'; cr.
  ^nil].
  (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
  [self printHex: oop; print: ' is misaligned'; cr.
  ^nil].
  (objectMemory isFreeObject: oop) ifTrue:
  [self print: ' free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr.
  ^nil].
  self print: ': a(n) '.
  self printNameOfClass: (cls := objectMemory fetchClassOfNonInt: oop) count: 5.
  cls = (objectMemory splObj: ClassFloat) ifTrue:
  [self cr; printFloat: (self dbgFloatValueOf: oop); cr.
  ^nil].
  fmt := objectMemory formatOf: oop.
  fmt > 4 ifTrue:
  [self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)].
  self cr.
  (fmt > 4 and: [fmt < 12]) ifTrue:
  ["This will answer false if splObj: ClassAlien is nilObject"
  (self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue:
  [self print: ' datasize '; printNum: (self sizeOfAlienData: oop).
  self print: ((self isIndirectAlien: oop)
  ifTrue: [' indirect @ ']
  ifFalse:
  [(self isPointerAlien: oop)
  ifTrue: [' pointer @ ']
  ifFalse: [' direct @ ']]).
+ self printHex: (self startOfAlienData: oop) asUnsignedInteger; cr.
- self printHex: (self startOfAlienData: oop); cr.
  ^nil].
  (objectMemory isWords: oop) ifTrue:
  [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / BytesPerWord).
  lastIndex > 0 ifTrue:
  [1 to: lastIndex do:
  [:index|
  self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop).
  (index \\ self elementsPerPrintOopLine) = 0 ifTrue:
  [self cr]].
  (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
  [self cr]].
  ^nil].
  ^self printStringOf: oop; cr].
  lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord).
  lastIndex > 0 ifTrue:
  [1 to: lastIndex do:
  [:index|
  self cCode: 'printHex(fetchPointerofObject(index - 1, oop)); putchar('' '')'
  inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space.
  self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))].
  (index \\ self elementsPerPrintOopLine) = 0 ifTrue:
  [self cr]].
  (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
  [self cr]].
  (objectMemory isCompiledMethod: oop)
  ifFalse:
  [startIP > 64 ifTrue: [self print: '...'; cr]]
  ifTrue:
  [startIP := startIP * BytesPerWord + 1.
  lastIndex := objectMemory lengthOf: oop.
  lastIndex - startIP > 100 ifTrue:
  [lastIndex := startIP + 100].
  bytecodesPerLine := 10.
  startIP to: lastIndex do:
  [:index| | byte |
  byte := objectMemory fetchByte: index - 1 ofObject: oop.
  self cCode: 'printf(" %02x/%-3d", byte,byte)'
  inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
  ((index - startIP + 1) \\ bytecodesPerLine) = 0 ifTrue:
  [self cr]].
  ((lastIndex - startIP + 1) \\ bytecodesPerLine) = 0 ifFalse:
  [self cr]]!

Item was changed:
  ----- Method: StackInterpreter>>pushMaybeContextReceiverVariable: (in category 'stack bytecodes') -----
  pushMaybeContextReceiverVariable: fieldIndex
  "Must trap accesses to married and widowed contexts.
  But don't want to check on all inst var accesses.  This
  method is only used by the long-form bytecodes, evading
  the cost. Note that the method, closure and receiver fields
  of married contexts are correctly initialized so they don't
  need special treatment on read.  Only sender, instruction
  pointer and stack pointer need to be intercepted on reads."
  | rcvr |
  <inline: true>
  rcvr := self receiver.
  (fieldIndex < MethodIndex
+ and: [objectMemory isContextNonInt: rcvr])
- and: [self isContextNonInt: rcvr])
  ifTrue:
  [self internalPush: (self instVar: fieldIndex ofContext: rcvr)]
  ifFalse:
  [self internalPush: (objectMemory fetchPointer: fieldIndex ofObject: rcvr)]!

Item was changed:
  ----- Method: StackInterpreter>>stObject:at: (in category 'indexing primitive support') -----
  stObject: array at: index
  "Return what ST would return for <obj> at: index."
 
  | hdr fmt totalLength fixedFields stSize |
  <inline: false>
  hdr := objectMemory baseHeader: array.
  fmt := objectMemory formatOfHeader: hdr.
  totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt.
  fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength.
+ (fmt = 3 and: [objectMemory isContextHeader: hdr])
- (fmt = 3 and: [self isContextHeader: hdr])
  ifTrue:
  [stSize := self fetchStackPointerOf: array.
  ((self oop: index isGreaterThanOrEqualTo: 1)
  and: [(self oop: index isLessThanOrEqualTo: stSize)
  and: [self isStillMarriedContext: array]]) ifTrue:
  [^self noInlineTemporary: index - 1 in: (self frameOfMarriedContext: array)]]
  ifFalse: [stSize := totalLength - fixedFields].
  ((self oop: index isGreaterThanOrEqualTo: 1)
  and: [self oop: index isLessThanOrEqualTo: stSize])
  ifTrue: [^self subscript: array with: (index + fixedFields) format: fmt]
  ifFalse: [self primitiveFailFor: PrimErrBadIndex.  ^ 0]!

Item was changed:
  ----- Method: StackInterpreter>>stObject:at:put: (in category 'indexing primitive support') -----
  stObject: array at: index put: value
  "Do what ST would return for <obj> at: index put: value."
  | hdr fmt totalLength fixedFields stSize |
  <inline: false>
  hdr := objectMemory baseHeader: array.
  fmt := objectMemory formatOfHeader: hdr.
  totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt.
  fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength.
+ (fmt = 3
+ and: [objectMemory isContextHeader: hdr])
- (fmt = 3 and: [self isContextHeader: hdr])
  ifTrue:
  [stSize := self fetchStackPointerOf: array.
  ((self oop: index isGreaterThanOrEqualTo: 1)
  and: [(self oop: index isLessThanOrEqualTo: stSize)
  and: [self isStillMarriedContext: array]]) ifTrue:
  [self noInlineTemporary: index - 1 in: (self frameOfMarriedContext: array) put: value.
  ^self]]
  ifFalse: [stSize := totalLength - fixedFields].
  ((self oop: index isGreaterThanOrEqualTo: 1)
  and: [self oop: index isLessThanOrEqualTo: stSize])
  ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt]
  ifFalse: [self primitiveFailFor: PrimErrBadIndex]!

Item was changed:
  ----- Method: StackInterpreter>>storeMaybeContextReceiverVariable:withValue: (in category 'stack bytecodes') -----
  storeMaybeContextReceiverVariable: fieldIndex withValue: anObject
  "Must trap accesses to married and widowed contexts.
  But don't want to check on all inst var accesses.  This
  method is only used by the long-form bytecodes, evading the cost."
  | rcvr |
  rcvr := self receiver.
  (fieldIndex <= ReceiverIndex
+ and: [(objectMemory isContextNonInt: rcvr)
- and: [(self isContextNonInt: rcvr)
  and: [self isMarriedOrWidowedContext: rcvr]])
  ifTrue:
  [self instVar: fieldIndex ofContext: rcvr put: anObject]
  ifFalse:
  [objectMemory storePointer: fieldIndex ofObject: rcvr withValue: anObject]
  !

Item was removed:
- ----- Method: StackInterpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') -----
- sufficientSpaceToInstantiate: classOop indexableSize: size
- "Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields."
- "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
- | format atomSize|
- <inline: true>
- format := self instSpecOfClass: classOop.
-
- "fail if attempting to call new: on non-indexable class"
- ((self cCoerce: size to: 'usqInt ') > 0 and: [format < 2])
- ifTrue: [^ false].
-
- format < 8
- ifTrue: ["indexable fields are words or pointers" atomSize := BytesPerWord]
- ifFalse: ["indexable fields are bytes" atomSize := 1].
- ^objectMemory sufficientSpaceToAllocate: 2500 + (size * atomSize)!

Item was changed:
  ----- Method: StackInterpreterPrimitives>>primitiveClone (in category 'object access primitives') -----
  primitiveClone
  "Return a shallow copy of the receiver.
  Special-case non-single contexts (because of context-to-stack mapping).
  Can't fail for contexts cuz of image context instantiation code (sigh)."
 
  | rcvr newCopy |
  rcvr := self stackTop.
  (objectMemory isIntegerObject: rcvr)
  ifTrue:
  [newCopy := rcvr]
  ifFalse:
+ [(objectMemory isContextNonInt: rcvr)
- [(self isContextNonInt: rcvr)
  ifTrue:
  [newCopy := self cloneContext: rcvr]
  ifFalse:
  [newCopy := objectMemory clone: rcvr].
  newCopy = 0 ifTrue:
  [^self primitiveFailFor: PrimErrNoMemory]].
  self pop: 1 thenPush: newCopy!

Item was changed:
  ----- Method: StackInterpreterPrimitives>>primitiveCopyObject (in category 'object access primitives') -----
  primitiveCopyObject
  "Primitive. Copy the state of the receiver from the argument.
  Fail if receiver and argument are of a different class.
  Fail if the receiver or argument are non-pointer objects.
  Fail if the receiver or argument are contexts (because of context-to-stack mapping).
  Fail if receiver and argument have different lengths (for indexable objects).
  "
  | rcvr arg length |
  self methodArgumentCount = 1 ifFalse:
  [^self primitiveFail].
  arg := self stackObjectValue: 0.
  rcvr := self stackObjectValue: 1.
 
  self failed ifTrue:[^nil].
  (objectMemory isPointers: rcvr) ifFalse:
  [^self primitiveFail].
+ ((objectMemory isContextNonInt: rcvr)
+ or: [objectMemory isContextNonInt: arg]) ifTrue:
- ((self isContextNonInt: rcvr)
- or: [self isContextNonInt: arg]) ifTrue:
  [^self primitiveFail].
  (objectMemory fetchClassOfNonInt: rcvr) = (objectMemory fetchClassOfNonInt: arg) ifFalse:
  [^self primitiveFail].
  length := objectMemory lengthOf: rcvr.
  length = (objectMemory lengthOf: arg) ifFalse:
  [^self primitiveFail].
 
  "Now copy the elements"
+ 0 to: length-1 do:
+ [:i|
- 0 to: length-1 do:[:i|
  objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)].
 
  "Note: The above could be faster for young receivers but I don't think it'll matter"
+ self pop: 1 "pop arg; answer receiver"
- self pop: 1. "pop arg; answer receiver"
  !