VM Maker: VMMaker-dtl.173.mcz

 
Dave Lewis uploaded a new version of VMMaker to project VM Maker:
http://www.squeaksource.com/VMMaker/VMMaker-dtl.173.mcz

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

Name: VMMaker-dtl.173
Author: dtl
Time: 19 May 2010, 5:26:58 am
UUID: bbb194b8-b409-4b48-a757-7d9466006019
Ancestors: VMMaker-dtl.172

VMMaker 4.2.0

EXPERIMENTAL - Includes numerous code changes that may cause problems for other VM projects that rely on a stable VMMaker code base.

Compile a VM for either 32-bit or 64-bit image from a single generated code base. Eliminates need for separate src32 and src64 code generation from VMMaker.

Various word-size dependent class variables are removed from ObjectMemory. C preprocessor macros are written to src/vm/interp.h to handle all compile-time size dependencies. The interpreter simulator uses a mix of class variables and instance methods to implement the corresponding calculations in Smalltalk.

To compile a VM for 64-bit images, define the following in config.h or equivalent:

#define SQ_VI_BYTES_PER_WORD 8

=============== Diff against VMMaker-dtl.172 ===============

Item was changed:
  ----- Method: ObjectMemory>>prepareForwardingTableForBecoming:with:twoWay: (in category 'become') -----
  prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag
  "Ensure that there are enough forwarding blocks to
  accomodate this become, then prepare forwarding blocks for
  the pointer swap. Return true if successful."
  "Details: Doing a GC might generate enough space for
  forwarding blocks if we're short. However, this is an
  uncommon enough case that it is better handled by primitive
  fail code at the Smalltalk level."
 
  "Important note on multiple references to same object  - since the preparation of
  fwdBlocks is NOT idempotent we get VM crashes if the same object is referenced more
  than once in such a way as to require multiple fwdBlocks.
  oop1 forwardBecome: oop1 is ok since only a single fwdBlock is needed.
  oop1 become: oop1 would fail because the second fwdBlock woudl not have the actual object
  header but rather the mutated ref to the first fwdBlock.
  Further problems can arise with an array1 or array2 that refer multiply to the same
  object. This would notbe expected input for programmer writen code but might arise from
  automatic usage such as in ImageSegment loading.
  To avoid the simple and rather common case of oop1 become*: oop1, we skip such pairs
  and simply avoid making fwdBlocks - it is redundant anyway"
  | entriesNeeded entriesAvailable fieldOffset oop1 oop2 fwdBlock fwdBlkSize |
+ entriesNeeded := (self lastPointerOf: array1) // self bytesPerWord. "need enough entries for all oops"
- entriesNeeded := (self lastPointerOf: array1) // BytesPerWord. "need enough entries for all oops"
  "Note: Forward blocks must be quadword aligned - see fwdTableInit:."
  twoWayFlag
  ifTrue: ["Double the number of blocks for two-way become"
  entriesNeeded := entriesNeeded * 2.
+ fwdBlkSize := self bytesPerWord * 2]
- fwdBlkSize := BytesPerWord * 2]
  ifFalse: ["One-way become needs backPointers in fwd blocks."
+ fwdBlkSize := self bytesPerWord * 4].
- fwdBlkSize := BytesPerWord * 4].
  entriesAvailable := self fwdTableInit: fwdBlkSize.
  entriesAvailable < entriesNeeded
  ifTrue: [self initializeMemoryFirstFree: freeBlock.
  "re-initialize the free block"
  ^ false].
  fieldOffset := self lastPointerOf: array1.
+ [fieldOffset >= self baseHeaderSize]
- [fieldOffset >= BaseHeaderSize]
  whileTrue: [oop1 := self longAt: array1 + fieldOffset.
  oop2 := self longAt: array2 + fieldOffset.
  "if oop1 == oop2, no need to do any work for this pair.
  May still be other entries in the arrays though so keep looking"
  oop1 = oop2
  ifFalse: [fwdBlock := self fwdBlockGet: fwdBlkSize.
  self
  initForwardBlock: fwdBlock
  mapping: oop1
  to: oop2
  withBackPtr: twoWayFlag not.
  twoWayFlag
  ifTrue: ["Second block maps oop2 back to oop1 for two-way become"
  fwdBlock := self fwdBlockGet: fwdBlkSize.
  self
  initForwardBlock: fwdBlock
  mapping: oop2
  to: oop1
  withBackPtr: twoWayFlag not]].
+ fieldOffset := fieldOffset - self bytesPerWord].
- fieldOffset := fieldOffset - BytesPerWord].
  ^ true!

Item was changed:
  ----- Method: Interpreter>>primitiveVMPath (in category 'system control primitives') -----
  primitiveVMPath
  "Return a string containing the path name of VM's directory."
 
  | s sz |
  sz := self vmPathSize.
  s := self instantiateClass: (self splObj: ClassString) indexableSize: sz.
+ self vmPathGet: (s + self baseHeaderSize) Length: sz.
- self vmPathGet: (s + BaseHeaderSize) Length: sz.
  self pop: 1 thenPush: s.
  !

Item was changed:
  ----- Method: Interpreter>>okayOop: (in category 'debug support') -----
  okayOop: signedOop
  "Verify that the given oop is legitimate. Check address, header, and size but not class."
 
  | sz type fmt unusedBit oop |
  self var: #oop type: 'usqInt'.
  oop := self cCoerce: signedOop to: 'usqInt'.
 
  "address and size checks"
  (self isIntegerObject: oop) ifTrue: [ ^true ].
  (oop < endOfMemory)
  ifFalse: [ self error: 'oop is not a valid address' ].
+ ((oop \\ self bytesPerWord) = 0)
- ((oop \\ BytesPerWord) = 0)
  ifFalse: [ self error: 'oop is not a word-aligned address' ].
  sz := self sizeBitsOf: oop.
  (oop + sz) < endOfMemory
  ifFalse: [ self error: 'oop size would make it extend beyond the end of memory' ].
 
  "header type checks"
  type := self headerType: oop.
  type = HeaderTypeFree
  ifTrue:  [ self error: 'oop is a free chunk, not an object' ].
  type = HeaderTypeShort ifTrue: [
  (((self baseHeader: oop) >> 12) bitAnd: 16r1F) = 0
  ifTrue:  [ self error: 'cannot have zero compact class field in a short header' ].
  ].
  type = HeaderTypeClass ifTrue: [
+ ((oop >= self bytesPerWord) and: [(self headerType: oop - self bytesPerWord) = type])
- ((oop >= BytesPerWord) and: [(self headerType: oop - BytesPerWord) = type])
  ifFalse: [ self error: 'class header word has wrong type' ].
  ].
  type = HeaderTypeSizeAndClass ifTrue: [
+ ((oop >= (self bytesPerWord * 2)) and:
+ [(self headerType: oop - (self bytesPerWord * 2)) = type and:
+ [(self headerType: oop - self bytesPerWord) = type]])
- ((oop >= (BytesPerWord*2)) and:
- [(self headerType: oop - (BytesPerWord*2)) = type and:
- [(self headerType: oop - BytesPerWord) = type]])
  ifFalse: [ self error: 'class header word has wrong type' ].
  ].
 
  "format check"
  fmt := self formatOf: oop.
  ((fmt = 5) | (fmt = 7))
  ifTrue:  [ self error: 'oop has an unknown format type' ].
 
  "mark and root bit checks"
  unusedBit := 16r20000000.
+ self bytesPerWord = 8
- BytesPerWord = 8
  ifTrue:
  [unusedBit := unusedBit << 16.
  unusedBit := unusedBit << 16].
  ((self longAt: oop) bitAnd: unusedBit) = 0
  ifFalse: [ self error: 'unused header bit 30 is set; should be zero' ].
  "xxx
  ((self longAt: oop) bitAnd: MarkBit) = 0
  ifFalse: [ self error: 'mark bit should not be set except during GC' ].
  xxx"
+ (((self longAt: oop) bitAnd: self rootBit) = 1 and:
- (((self longAt: oop) bitAnd: RootBit) = 1 and:
  [oop >= youngStart])
  ifTrue: [ self error: 'root bit is set in a young object' ].
  ^true
  !

Item was changed:
  ----- Method: ObjectMemory class>>initializeWithBytesToWord: (in category 'initialization') -----
  initializeWithBytesToWord:  numberOfBytesInAWord
  "ObjectMemory initializeWithBytesToWord: Smalltalk wordSize"
 
  self initBytesPerWord: numberOfBytesInAWord.
 
  "Translation flags (booleans that control code generation via conditional translation):"
  DoAssertionChecks := false.  "generate assertion checks"
  DoBalanceChecks := false. "generate stack balance checks"
 
  self initializeSpecialObjectIndices.
  self initializeObjectHeaderConstants.
 
  CtxtTempFrameStart := 6.  "Copy of TempFrameStart in Interp"
  ContextFixedSizePlusHeader := CtxtTempFrameStart + 1.
- SmallContextSize := ContextFixedSizePlusHeader + 16 * BytesPerWord.  "16 indexable fields"
- "Large contexts have 56 indexable fileds.  Max with single header word."
- "However note that in 64 bits, for now, large contexts have 3-word headers"
- LargeContextSize := ContextFixedSizePlusHeader + 56 * BytesPerWord.
 
  LargeContextBit := 16r40000.  "This bit set in method headers if large context is needed."
  NilContext := 1.  "the oop for the integer 0; used to mark the end of context lists"
 
  RemapBufferSize := 25.
  RootTableSize := 2500.   "number of root table entries (4 bytes/entry)"
  RootTableRedZone := RootTableSize - 100. "red zone of root table - when reached we force IGC"
 
  "tracer actions"
  StartField := 1.
  StartObj := 2.
  Upward := 3.
  Done := 4.
 
  ExtraRootSize := 2048. "max. # of external roots"!

Item was changed:
  ----- Method: ObjectMemory>>restoreHeaderOf: (in category 'become') -----
  restoreHeaderOf: oop
  "Restore the original header of the given oop from its
  forwarding block."
  | fwdHeader fwdBlock |
  fwdHeader := self longAt: oop.
+ fwdBlock := (fwdHeader bitAnd: self allButMarkBitAndTypeMask) << 1.
- fwdBlock := (fwdHeader bitAnd: AllButMarkBitAndTypeMask) << 1.
  DoAssertionChecks
+ ifTrue: [(fwdHeader bitAnd: self markBit) = 0
- ifTrue: [(fwdHeader bitAnd: MarkBit) = 0
  ifTrue: [self error: 'attempting to restore the header of an object that has no forwarding block'].
  self fwdBlockValidate: fwdBlock].
+ self longAt: oop put: (self longAt: fwdBlock + self bytesPerWord)!
- self longAt: oop put: (self longAt: fwdBlock + BytesPerWord)!

Item was changed:
  ----- Method: Interpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') -----
  sufficientSpaceToInstantiate: classOop indexableSize: size
  "Return true if there is enough space 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 |
  self inline: true.
  self var: #size type: 'usqInt'.
  self var: #bytesNeeded type: 'usqInt'.
  format := (self formatOfClass: classOop) >> 8 bitAnd: 16rF.
 
  "Fail if attempting to call new: on non-indexable class"
  (size > 0 and: [format < 2])
  ifTrue: [^ false].
 
  format < 8
  ifTrue: ["indexable fields are words or pointers"
+ (self isExcessiveAllocationRequest: size shift: self shiftForWord) ifTrue: [^ false].
+ ^ self sufficientSpaceToAllocate: 2500 + (size * self bytesPerWord)]
- (self isExcessiveAllocationRequest: size shift: ShiftForWord) ifTrue: [^ false].
- ^ self sufficientSpaceToAllocate: 2500 + (size * BytesPerWord)]
  ifFalse: ["indexable fields are bytes"
  (self isExcessiveAllocationRequest: size shift: 0) ifTrue: [^ false].
  ^ self sufficientSpaceToAllocate: 2500 + size]
  !

Item was changed:
  ----- Method: Interpreter>>push: (in category 'contexts') -----
  push: object
 
  | sp |
+ self longAt: (sp := stackPointer + self bytesPerWord) put: object.
- self longAt: (sp := stackPointer + BytesPerWord) put: object.
  stackPointer := sp.!

Item was changed:
  ----- Method: ObjectMemory>>remapClassOf: (in category 'gc -- compaction') -----
  remapClassOf: oop
  "Update the class of the given object, if necessary, using its forwarding table entry."
  "Note: Compact classes need not be remapped since the compact class field is just an index into the compact class
  table. The header type bits show if this object has a compact class; we needn't look up the oop's real header."
  | classHeader classOop fwdBlock newClassOop newClassHeader |
  (self headerType: oop) = HeaderTypeShort ifTrue: [^ nil]. "compact classes needn't be mapped"
 
+ classHeader := self longAt: oop - self bytesPerWord.
+ classOop := classHeader bitAnd: self allButTypeMask.
- classHeader := self longAt: oop - BytesPerWord.
- classOop := classHeader bitAnd: AllButTypeMask.
  (self isObjectForwarded: classOop)
+ ifTrue: [fwdBlock := ((self longAt: classOop) bitAnd: self allButMarkBitAndTypeMask) << 1.
- ifTrue: [fwdBlock := ((self longAt: classOop) bitAnd: AllButMarkBitAndTypeMask) << 1.
  DoAssertionChecks
  ifTrue: [self fwdBlockValidate: fwdBlock].
  newClassOop := self longAt: fwdBlock.
  newClassHeader := newClassOop bitOr: (classHeader bitAnd: TypeMask).
+ self longAt: oop - self bytesPerWord put: newClassHeader.
- self longAt: oop - BytesPerWord put: newClassHeader.
  "The following ensures that become: into an old object's class makes it a root.
  It does nothing during either incremental or full compaction because
  oop will never be < youngStart."
  ((self oop: oop isLessThan: youngStart)
  and: [self oop: newClassOop isGreaterThanOrEqualTo: youngStart])
  ifTrue: [self beRootWhileForwarding: oop]]!

Item was changed:
  ----- Method: Interpreter>>primitiveObjectPointsTo (in category 'object access primitives') -----
  primitiveObjectPointsTo
  | rcvr thang lastField |
  thang := self popStack.
  rcvr := self popStack.
  (self isIntegerObject: rcvr) ifTrue: [^self pushBool: false].
 
  lastField := self lastPointerOf: rcvr.
+ self baseHeaderSize to: lastField by: self bytesPerWord do:
- BaseHeaderSize to: lastField by: BytesPerWord do:
  [:i | (self longAt: rcvr + i) = thang
  ifTrue: [^ self pushBool: true]].
  self pushBool: false.!

Item was changed:
  ----- Method: ObjectMemory>>recycleContextIfPossible: (in category 'allocation') -----
  recycleContextIfPossible: cntxOop
  "If possible, save the given context on a list of free contexts to
  be recycled."
  "Note: The context is not marked free, so it can be reused
  with minimal fuss. The recycled context lists are cleared at
  every garbage collect."
  | header |
  self inline: true.
  "only recycle young contexts (which should be most of them)"
  (self oop: cntxOop isGreaterThanOrEqualTo: youngStart)
  ifTrue: [header := self baseHeader: cntxOop.
  (self isMethodContextHeader: header)
  ifTrue: ["It's a young context, alright."
+ (header bitAnd: self sizeMask) = self smallContextSize
- (header bitAnd: SizeMask) = SmallContextSize
  ifTrue: ["Recycle small contexts"
  self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeContexts.
  freeContexts := cntxOop].
+ (header bitAnd: self sizeMask) = self largeContextSize
- (header bitAnd: SizeMask) = LargeContextSize
  ifTrue: ["Recycle large contexts"
  self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeLargeContexts.
  freeLargeContexts := cntxOop]]]!

Item was changed:
  ----- Method: Interpreter>>imageFormatCompatibilityVersion (in category 'image save/restore') -----
  imageFormatCompatibilityVersion
  "This VM is backward-compatible with the immediately preceeding non-closure version."
 
+ self bytesPerWord == 4
- BytesPerWord == 4
  ifTrue: [^6502]
  ifFalse: [^68000]!

Item was changed:
  ----- Method: Interpreter>>pop:thenPush: (in category 'contexts') -----
  pop: nItems thenPush: oop
 
  | sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * self bytesPerWord)) put: oop.
- self longAt: (sp := stackPointer - ((nItems - 1) * BytesPerWord)) put: oop.
  stackPointer := sp.
  !

Item was changed:
  ----- Method: Interpreter>>byteLengthOf: (in category 'array primitive support') -----
  byteLengthOf: oop
  "Return the number of indexable bytes in the given object. This is basically a special copy of lengthOf: for BitBlt."
  | header sz fmt |
  header := self baseHeader: oop.
  (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self allButTypeMask ]
+ ifFalse: [ sz := header bitAnd: self sizeMask ].
- ifTrue: [ sz := (self sizeHeader: oop) bitAnd: AllButTypeMask ]
- ifFalse: [ sz := header bitAnd: SizeMask ].
  fmt := (header >> 8) bitAnd: 16rF.
  fmt < 8
+ ifTrue: [ ^ (sz - self baseHeaderSize)]  "words"
+ ifFalse: [ ^ (sz - self baseHeaderSize) - (fmt bitAnd: 3)]  "bytes"!
- ifTrue: [ ^ (sz - BaseHeaderSize)]  "words"
- ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3)]  "bytes"!

Item was changed:
  ----- Method: Interpreter>>pushClosureCopyCopiedValuesBytecode (in category 'stack bytecodes') -----
  pushClosureCopyCopiedValuesBytecode
  "The compiler has pushed the values to be copied, if any.  Find numArgs and numCopied in the byte following.
  Create a Closure with space for the copiedValues and pop numCopied values off the stack into the closure.
  Set numArgs as specified, and set startpc to the pc following the block size and jump over that code."
  | newClosure numArgsNumCopied numArgs numCopied blockSize |
+ self bytesPerWord == 4
- BytesPerWord == 4
  ifTrue: [imageFormatVersionNumber := 6504]
  ifFalse: [imageFormatVersionNumber := 68002].
  numArgsNumCopied := self fetchByte.
  numArgs := numArgsNumCopied bitAnd: 16rF.
  numCopied := numArgsNumCopied bitShift: -4.
  "Split blockSize := (self fetchByte * 256) + self fetchByte. into two because evaluation order in C is undefined."
  blockSize := self fetchByte << 8.
  blockSize := blockSize + self fetchByte.
  self externalizeIPandSP. "This is a pain."
  newClosure := self
  closureNumArgs: numArgs
+ instructionPointer: ((self oopForPointer: localIP) + 2 - (method + self baseHeaderSize))
- instructionPointer: ((self oopForPointer: localIP) + 2 - (method+BaseHeaderSize))
  numCopiedValues: numCopied.
  self internalizeIPandSP.
  "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
  self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: activeContext.
  reclaimableContextCount := 0. "The closure refers to thisContext so it can't be reclaimed."
  numCopied > 0 ifTrue:
  [0 to: numCopied - 1 do:
  [:i|
  "Assume: have just allocated a new BlockClosure; it must be young.
  Thus, can use unchecked stores."
  self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
  ofObject: newClosure
  withValue: (self internalStackValue: numCopied - i - 1)].
  self internalPop: numCopied].
  localIP := localIP + blockSize.
  self fetchNextBytecode.
  self internalPush: newClosure!

Item was changed:
  ----- Method: ObjectMemory class>>initBytesPerWord: (in category 'initialization') -----
  initBytesPerWord: nBytes
 
  BytesPerWord := nBytes.
- ShiftForWord := (BytesPerWord log: 2) rounded.
  Byte0Shift := 0.
  Byte1Shift := 8.
  Byte2Shift := 16.
  Byte3Shift := 24.
  Byte4Shift := 32.
  Byte5Shift := 40.
  Byte6Shift := 48.
  Byte7Shift := 56.
 
  Byte0Mask := 16r00000000000000FF.
  Byte1Mask := 16r000000000000FF00.
  Byte2Mask := 16r0000000000FF0000.
  Byte3Mask := 16r00000000FF000000.
  Byte4Mask := 16r000000FF00000000.
  Byte5Mask := 16r0000FF0000000000.
  Byte6Mask := 16r00FF000000000000.
  Byte7Mask := 16rFF00000000000000.
  Bytes3to0Mask := 16r00000000FFFFFFFF.
  Bytes7to4Mask := 16rFFFFFFFF00000000.
 
  Byte1ShiftNegated := Byte1Shift negated.
  Byte3ShiftNegated := Byte3Shift negated.
  Byte4ShiftNegated := Byte4Shift negated.
  Byte5ShiftNegated := Byte5Shift negated.
  Byte7ShiftNegated := Byte7Shift negated!

Item was changed:
  ----- Method: ObjectMemory class>>unsignedIntegerSuffix (in category 'translation') -----
  unsignedIntegerSuffix
  "Answer the suffix that should be appended to unsigned integer literals in generated code."
 
+ ^ 'U'
+
+ "The U declaration is sufficient for 64-bit cases - dtl"
+ "^BytesPerWord = 4 ifTrue: ['U'] ifFalse: ['ULL']"!
- ^BytesPerWord = 4 ifTrue: ['U'] ifFalse: ['ULL']!

Item was changed:
  ----- Method: Interpreter>>primitiveDoNamedPrimitiveWithArgs (in category 'plugin primitives') -----
  primitiveDoNamedPrimitiveWithArgs
  "Simulate an primitiveExternalCall invocation (e.g. for the Debugger).  Do not cache anything.
  e.g. ContextPart>>tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments"
  | argumentArray arraySize index methodArg methodHeader spec
   moduleName functionName moduleLength functionLength addr |
  self var: #addr declareC: 'void (*addr)()'.
 
  argumentArray := self stackTop.
  (self isArray: argumentArray) ifFalse:
  [^self primitiveFail]. "invalid args"
  arraySize := self fetchWordLengthOf: argumentArray.
  self success: (self roomToPushNArgs: arraySize).
 
  methodArg := self stackObjectValue: 2.
  successFlag ifFalse:
  [^self primitiveFail]. "invalid args"
 
  (self isCompiledMethod: methodArg) ifFalse:
  [^self primitiveFail]. "invalid args"
 
  methodHeader := self headerOf: methodArg.
 
  (self literalCountOfHeader: methodHeader) > 2 ifFalse:
  [^self primitiveFail]. "invalid methodArg state"
  self assertClassOf: (spec := self fetchPointer: 1 "first literal" ofObject: methodArg)
  is: (self splObj: ClassArray).
  (successFlag
  and: [(self lengthOf: spec) = 4
  and: [(self primitiveIndexOfMethodHeader: methodHeader) = 117]]) ifFalse:
  [^self primitiveFail]. "invalid methodArg state"
 
  (self argumentCountOfMethodHeader: methodHeader) = arraySize ifFalse:
  [^self primitiveFail]. "invalid args (Array args wrong size)"
 
  "The function has not been loaded yet. Fetch module and function name."
  moduleName := self fetchPointer: 0 ofObject: spec.
  moduleName = nilObj
  ifTrue: [moduleLength := 0]
  ifFalse: [self success: (self isBytes: moduleName).
  moduleLength := self lengthOf: moduleName.
  self cCode: '' inSmalltalk:
  [ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName)) "??"
  ifTrue: [moduleLength := 0  "Cause all of these to fail"]]].
  functionName := self fetchPointer: 1 ofObject: spec.
  self success: (self isBytes: functionName).
  functionLength := self lengthOf: functionName.
  successFlag ifFalse: [^self primitiveFail]. "invalid methodArg state"
 
+ addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
- addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
  OfLength: functionLength
+ FromModule: moduleName + self baseHeaderSize
- FromModule: moduleName + BaseHeaderSize
  OfLength: moduleLength.
  addr = 0 ifTrue:
  [^self primitiveFail]. "could not find function"
 
  "Cannot fail this primitive from now on.  Can only fail the external primitive."
  self pop: 1.
  argumentCount := arraySize.
  index := 1.
  [index <= arraySize] whileTrue:
  [self push: (self fetchPointer: index - 1 ofObject: argumentArray).
  index := index + 1].
 
  "Run the primitive (sets primFailCode)"
  self pushRemappableOop: argumentArray. "prim might alloc/gc in callback"
  lkupClass := nilObj.
  self callExternalPrimitive: addr.
  argumentArray := self popRemappableOop.
  successFlag ifFalse: "If primitive failed, then restore state for failure code"
  [self pop: arraySize thenPush: argumentArray.
  argumentCount := 3]!

Item was changed:
  ----- Method: Interpreter>>pop: (in category 'contexts') -----
  pop: nItems
  "Note: May be called by translated primitive code."
 
+ stackPointer := stackPointer - (nItems * self bytesPerWord).!
- stackPointer := stackPointer - (nItems*BytesPerWord).!

Item was changed:
  ----- Method: Interpreter>>wordSwapped: (in category 'image save/restore') -----
  wordSwapped: w
  "Return the given 64-bit integer with its halves in the reverse order."
 
  self inline: true.
+ self isDefinedTrueExpression: 'BYTES_PER_WORD == 8'
+ inSmalltalk: [self bytesPerWord = 8]
- self isDefinedTrueExpression: 'SQ_VI_BYTES_PER_WORD == 8'
- inSmalltalk: [BytesPerWord = 8]
  comment: 'swap 32-bit ends of a 64-bit object word'
  ifTrue: [^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask)
    + ((w bitShift: Byte4Shift) bitAnd: Bytes7to4Mask)]
  ifFalse: [self error: 'This cannot happen.']
  !

Item was changed:
  ----- Method: Interpreter>>positive32BitIntegerFor: (in category 'primitive support') -----
  positive32BitIntegerFor: integerValue
 
  | newLargeInteger |
  "Note - integerValue is interpreted as POSITIVE, eg, as the result of
  Bitmap>at:, or integer>bitAnd:."
  integerValue >= 0
  ifTrue: [(self isIntegerValue: integerValue)
  ifTrue: [^ self integerObjectOf: integerValue]].
 
+ self bytesPerWord = 4
- BytesPerWord = 4
  ifTrue: ["Faster instantiateSmallClass: currently only works with integral word size."
  newLargeInteger := self instantiateSmallClass: (self splObj: ClassLargePositiveInteger)
+ sizeInBytes: self baseHeaderSize + 4]
- sizeInBytes: BaseHeaderSize + 4]
  ifFalse: ["Cant use instantiateSmallClass: due to integral word requirement."
  newLargeInteger := self instantiateClass: (self splObj: ClassLargePositiveInteger)
  indexableSize: 4].
  self storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
  self storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
  self storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
  self storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
  ^ newLargeInteger!

Item was changed:
  ----- Method: Interpreter>>byteSwapByteObjectsFrom:to: (in category 'image save/restore') -----
  byteSwapByteObjectsFrom: startOop to: stopAddr
  "Byte-swap the words of all bytes objects in a range of the
  image, including Strings, ByteArrays, and CompiledMethods.
  This returns these objects to their original byte ordering
  after blindly byte-swapping the entire image. For compiled
  methods, byte-swap only their bytecodes part."
  | oop fmt wordAddr methodHeader |
  oop := startOop.
  [self oop: oop isLessThan: stopAddr]
  whileTrue: [(self isFreeObject: oop)
  ifFalse: [fmt := self formatOf: oop.
  fmt >= 8
  ifTrue: ["oop contains bytes"
+ wordAddr := oop + self baseHeaderSize.
- wordAddr := oop + BaseHeaderSize.
  fmt >= 12
  ifTrue: ["compiled method; start after methodHeader and literals"
+ methodHeader := self longAt: oop + self baseHeaderSize.
+ wordAddr := wordAddr + self bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * self bytesPerWord)].
- methodHeader := self longAt: oop + BaseHeaderSize.
- wordAddr := wordAddr + BytesPerWord + ((methodHeader >> 10 bitAnd: 255) * BytesPerWord)].
  self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop)].
+ (fmt = 6 and: [self bytesPerWord = 8])
- (fmt = 6 and: [BytesPerWord = 8])
  ifTrue: ["Object contains 32-bit half-words packed into 64-bit machine words."
+ wordAddr := oop + self baseHeaderSize.
- wordAddr := oop + BaseHeaderSize.
  self reverseWordsFrom: wordAddr to: oop + (self sizeBitsOf: oop)]].
  oop := self objectAfter: oop]!

Item was added:
+ ----- Method: ObjectMemory>>shiftForWord (in category 'constants') -----
+ shiftForWord
+
+ self inline: true.
+ ^self
+ cCode: 'SHIFT_FOR_WORD'
+ inSmalltalk: [(self bytesPerWord log: 2) rounded]
+ !

Item was changed:
(excessive method size, no diff calculated)

Item was changed:
  ----- Method: Interpreter>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') -----
  primitiveClosureCopyWithCopiedValues
  | newClosure copiedValues numCopiedValues numArgs |
  numArgs := self stackIntegerValue: 1.
  copiedValues := self stackTop.
  self success: (self fetchClassOf: copiedValues) = (self splObj: ClassArray).
  successFlag ifFalse:
  [^self primitiveFail].
  numCopiedValues := self fetchWordLengthOf: copiedValues.
  newClosure := self
  closureNumArgs: numArgs
  "greater by 1 due to preIncrement of localIP"
+ instructionPointer: instructionPointer + 2 - (method + self baseHeaderSize)
- instructionPointer: instructionPointer + 2 - (method+BaseHeaderSize)
  numCopiedValues: numCopiedValues.
  "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
  self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2).
  numCopiedValues > 0 ifTrue:
  ["Allocation may have done a GC and copiedValues may have moved."
  copiedValues := self stackTop.
  0 to: numCopiedValues - 1 do:
  [:i|
  "Assume: have just allocated a new BlockClosure; it must be young.
  Thus, can use unchecked stores."
  self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
  ofObject: newClosure
  withValue: (self fetchPointer: i ofObject: copiedValues)]].
  self pop: 3 thenPush: newClosure!

Item was changed:
  ----- Method: ObjectMemory>>fetchWordLengthOf: (in category 'interpreter access') -----
  fetchWordLengthOf: objectPointer
  "NOTE: this gives size appropriate for fetchPointer: n, but not in general for, eg, fetchLong32, etc."
 
  | sz |
  sz := self sizeBitsOf: objectPointer.
+ ^ (sz - self baseHeaderSize) >> self shiftForWord!
- ^ (sz - BaseHeaderSize) >> ShiftForWord!

Item was changed:
  ----- Method: Interpreter>>unPop: (in category 'contexts') -----
  unPop: nItems
+ stackPointer := stackPointer + (nItems * self bytesPerWord)!
- stackPointer := stackPointer + (nItems*BytesPerWord)!

Item was changed:
  ----- Method: Interpreter>>primitiveShortAtPut (in category 'array primitives') -----
  primitiveShortAtPut
  "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
 
  | index rcvr sz addr value |
  value := self stackIntegerValue: 0.
  index := self stackIntegerValue: 1.
  rcvr := self stackValue: 2.
  self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
  successFlag ifFalse: [ ^ nil ].
+ sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2.  "number of 16-bit fields"
- sz := ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2.  "number of 16-bit fields"
  self success: ((index >= 1) and: [index <= sz]).
  self success: ((value >= -32768) and: [value <= 32767]).
  successFlag ifTrue: [
+ addr := rcvr + self baseHeaderSize + (2 * (index - 1)).
- addr := rcvr + BaseHeaderSize + (2 * (index - 1)).
  self shortAt: addr put: value.
  self pop: 2.  "pop index and value; leave rcvr on stack"
  ]!

Item was changed:
  ----- Method: Interpreter>>activateNewMethod (in category 'message sending') -----
  activateNewMethod
  | newContext methodHeader initialIP tempCount nilOop where |
 
  methodHeader := self headerOf: newMethod.
  newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).
 
+ initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1.
- initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * BytesPerWord) + 1.
  tempCount := (methodHeader >> 19) bitAnd: 16r3F.
 
  "Assume: newContext will be recorded as a root if necessary by the
  call to newActiveContext: below, so we can use unchecked stores."
 
+ where :=  newContext  + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
+ self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
+ self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj.
- where :=  newContext  + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf: initialIP).
- self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.
- self longAt: where + (ClosureIndex << ShiftForWord) put: nilObj.
 
  "Copy the receiver and arguments..."
  0 to: argumentCount do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self stackValue: argumentCount-i)].
- [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self stackValue: argumentCount-i)].
 
  "clear remaining temps to nil in case it has been recycled"
  nilOop := nilObj.
  argumentCount+1+ReceiverIndex to: tempCount+ReceiverIndex do:
+ [:i | self longAt: where + (i << self shiftForWord) put: nilOop].
- [:i | self longAt: where + (i << ShiftForWord) put: nilOop].
 
  self pop: argumentCount + 1.
  reclaimableContextCount := reclaimableContextCount + 1.
  self newActiveContext: newContext.!

Item was changed:
  ----- Method: ObjectMemory>>lowestFreeAfter: (in category 'garbage collection') -----
  lowestFreeAfter: chunk
  "Return the first free block after the given chunk in memory."
  | oop oopHeader oopHeaderType oopSize |
  self inline: false.
  oop := self oopFromChunk: chunk.
  [self oop: oop isLessThan: endOfMemory]
  whileTrue: [oopHeader := self baseHeader: oop.
  oopHeaderType := oopHeader bitAnd: TypeMask.
  oopHeaderType = HeaderTypeFree
  ifTrue: [^ oop]
  ifFalse: [oopHeaderType = HeaderTypeSizeAndClass
+ ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: self allButTypeMask]
+ ifFalse: [oopSize := oopHeader bitAnd: self sizeMask]].
- ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: AllButTypeMask]
- ifFalse: [oopSize := oopHeader bitAnd: SizeMask]].
  oop := self oopFromChunk: oop + oopSize].
  self error: 'expected to find at least one free object'!

Item was changed:
  ----- Method: ObjectMemory>>incCompMove: (in category 'gc -- compaction') -----
  incCompMove: bytesFreed
  "Move all non-free objects between compStart and compEnd to their new  
  locations, restoring their headers in the process. Create a new free  
  block at the end of memory. Return the newly created free chunk. "
  "Note: The free block used by the allocator always must be the last free  
  block in memory. It may take several compaction passes to make all  
  free space bubble up to the end of memory."
  | oop next fwdBlock newOop header bytesToMove firstWord lastWord newFreeChunk sz target |
  self inline: false.
  self var: #firstWord type: 'usqInt'.
  self var: #lastWord type: 'usqInt'.
  self var: #w type: 'usqInt'.
  newOop := nil.
  oop := self oopFromChunk: compStart.
  [self oop: oop isLessThan: compEnd]
  whileTrue: [statCompMoveCount := statCompMoveCount + 1.
  next := self objectAfterWhileForwarding: oop.
  (self isFreeObject: oop)
  ifFalse: ["a moving object; unwind its forwarding block"
+ fwdBlock := ((self longAt: oop) bitAnd: self allButMarkBitAndTypeMask) << 1.
- fwdBlock := ((self longAt: oop) bitAnd: AllButMarkBitAndTypeMask) << 1.
  DoAssertionChecks
  ifTrue: [self fwdBlockValidate: fwdBlock].
  newOop := self longAt: fwdBlock.
+ header := self longAt: fwdBlock + self bytesPerWord.
- header := self longAt: fwdBlock + BytesPerWord.
  self longAt: oop put: header. "restore the original header"
  bytesToMove := oop - newOop. "move the oop (including any extra header words) "
  sz := self sizeBitsOf: oop.
  firstWord := oop - (self extraHeaderBytes: oop).
+ lastWord := oop + sz - self baseHeaderSize.
- lastWord := oop + sz - BaseHeaderSize.
  target := firstWord - bytesToMove.
+ firstWord to: lastWord by: self bytesPerWord
- firstWord to: lastWord by: BytesPerWord
  do: [:w |
  self longAt: target put: (self longAt: w).
+ target := target + self bytesPerWord]].
- target := target + BytesPerWord]].
  oop := next].
  newOop = nil
  ifTrue: ["no objects moved"
  oop := self oopFromChunk: compStart.
  ((self isFreeObject: oop) and: [(self objectAfter: oop) = (self oopFromChunk: compEnd)])
  ifTrue: [newFreeChunk := oop]
  ifFalse: [newFreeChunk := freeBlock]]
  ifFalse: ["initialize the newly freed memory chunk"
  "newOop is the last object moved; free chunk starts
  right after it"
  newFreeChunk := newOop + (self sizeBitsOf: newOop).
  self setSizeOfFree: newFreeChunk to: bytesFreed].
  DoAssertionChecks
  ifTrue: [(self objectAfter: newFreeChunk) = (self oopFromChunk: compEnd)
  ifFalse: [self error: 'problem creating free chunk after compaction']].
  (self objectAfter: newFreeChunk) = endOfMemory
  ifTrue: [self initializeMemoryFirstFree: newFreeChunk]
  ifFalse: ["newFreeChunk is not at end of memory; re-install freeBlock "
  self initializeMemoryFirstFree: freeBlock].
  ^ newFreeChunk!

Item was changed:
(excessive method size, no diff calculated)

Item was changed:
  ----- Method: Interpreter>>primitiveBeCursor (in category 'I/O primitives') -----
  primitiveBeCursor
  "Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk."
 
  | cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor |
 
  self flag: #Dan.  "This is disabled until we convert bitmaps appropriately"
+ self bytesPerWord = 8 ifTrue: [^ self pop: argumentCount].
- BytesPerWord = 8 ifTrue: [^ self pop: argumentCount].
 
  argumentCount = 0 ifTrue: [
  cursorObj := self stackTop.
  maskBitsIndex := nil].
  argumentCount = 1 ifTrue: [
  cursorObj := self stackValue: 1.
  maskObj := self stackTop].
  self success: (argumentCount < 2).
 
  self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]).
  successFlag ifTrue: [
  bitsObj := self fetchPointer: 0 ofObject: cursorObj.
  extentX := self fetchInteger: 1 ofObject: cursorObj.
  extentY := self fetchInteger: 2 ofObject: cursorObj.
  depth := self fetchInteger: 3 ofObject: cursorObj.
  offsetObj := self fetchPointer: 4 ofObject: cursorObj].
  self success: ((self isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]).
 
  successFlag ifTrue: [
  offsetX := self fetchInteger: 0 ofObject: offsetObj.
  offsetY := self fetchInteger: 1 ofObject: offsetObj.
 
  (argumentCount = 0 and: [depth = 32])
  ifTrue: [
  "Support arbitrary-sized 32 bit ARGB forms --bf 3/1/2007 23:51"
  self success: ((extentX > 0) and: [extentY > 0]).
  self success: ((offsetX >= (extentX * -1)) and: [offsetX <= 0]).
  self success: ((offsetY >= (extentY * -1)) and: [offsetY <= 0]).
+ cursorBitsIndex := bitsObj + self baseHeaderSize.
- cursorBitsIndex := bitsObj + BaseHeaderSize.
  self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = (extentX * extentY)]).
  self cCode: '' inSmalltalk:
  [ourCursor := Cursor
  extent: extentX @ extentY
  depth: 32
  fromArray: ((1 to: extentX * extentY) collect: [:i |
  self fetchLong32: i-1 ofObject: bitsObj])
  offset: offsetX  @ offsetY]]
  ifFalse: [
  self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
  self success: ((offsetX >= -16) and: [offsetX <= 0]).
  self success: ((offsetY >= -16) and: [offsetY <= 0]).
  self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
+ cursorBitsIndex := bitsObj + self baseHeaderSize.
- cursorBitsIndex := bitsObj + BaseHeaderSize.
  self cCode: '' inSmalltalk:
  [ourCursor := Cursor
  extent: extentX @ extentY
  fromArray: ((1 to: 16) collect: [:i |
  ((self fetchLong32: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF])
  offset: offsetX  @ offsetY]]].
 
  argumentCount = 1 ifTrue: [
  self success: ((self isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]).
  successFlag ifTrue: [
  bitsObj := self fetchPointer: 0 ofObject: maskObj.
  extentX := self fetchInteger: 1 ofObject: maskObj.
  extentY := self fetchInteger: 2 ofObject: maskObj.
  depth := self fetchInteger: 3 ofObject: maskObj].
 
  successFlag ifTrue: [
  self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
  self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
+ maskBitsIndex := bitsObj + self baseHeaderSize]].
- maskBitsIndex := bitsObj + BaseHeaderSize]].
 
 
  successFlag ifTrue: [
  argumentCount = 0
  ifTrue: [
  depth = 32
  ifTrue: [(self cCode: 'ioSetCursorARGB(cursorBitsIndex, extentX, extentY, offsetX, offsetY)'
  inSmalltalk: [ourCursor show. Cursor currentCursor == ourCursor])
  ifFalse: [^self success: false]]
  ifFalse: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)'
  inSmalltalk: [ourCursor show]]]
  ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)'
  inSmalltalk: [cursorBitsIndex == maskBitsIndex. "placate compiler"
  ourCursor show]].
  self pop: argumentCount]!

Item was changed:
  ----- Method: Interpreter>>primitiveIntegerAt (in category 'array primitives') -----
  primitiveIntegerAt
  "Return the 32bit signed integer contents of a words receiver"
 
  | index rcvr sz addr value intValue |
  self var: #intValue type: 'int'.
  index := self stackIntegerValue: 0.
  rcvr := self stackValue: 1.
  (self isIntegerObject: rcvr) ifTrue: [^self success: false].
  (self isWords: rcvr) ifFalse: [^self success: false].
  sz := self lengthOf: rcvr.  "number of fields"
  self success: ((index >= 1) and: [index <= sz]).
  successFlag ifTrue: [
+ addr := rcvr + self baseHeaderSize - 4 "for zero indexing" + (index * 4).
- addr := rcvr + BaseHeaderSize - 4 "for zero indexing" + (index * 4).
  value := self intAt: addr.
  self pop: 2.  "pop rcvr, index"
  "push element value"
  (self isIntegerValue: value)
  ifTrue: [self pushInteger: value]
  ifFalse: [
  intValue := value. "32 bit int may have been stored in 32 or 64 bit sqInt"
  self push: (self signed32BitIntegerFor: intValue)]. "intValue may be sign extended to 64 bit sqInt"
  ].!

Item was added:
+ ----- Method: InterpreterSimulator>>ioMicroSecondClock (in category 'I/O primitives support') -----
+ ioMicroSecondClock
+ "Answer the value of the high-resolution millisecond clock."
+
+ ^ self ioMicroMSecs * 1000
+ !

Item was changed:
  ----- Method: ObjectMemory>>fetchPointer:ofObject: (in category 'interpreter access') -----
  fetchPointer: fieldIndex ofObject: oop
  "index by word size, and return a pointer as long as the word size"
 
+ ^ self longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord)!
- ^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)!

Item was changed:
  ----- Method: ObjectMemory>>fwdTableInit: (in category 'gc -- compaction') -----
  fwdTableInit: blkSize
  "Set the limits for a table of two- or three-word forwarding blocks above the last used oop. The pointer fwdTableNext moves up to fwdTableLast. Used for compaction of memory and become-ing objects. Returns the number of forwarding blocks available."
 
  | |
  self inline: false.
  "set endOfMemory to just after a minimum-sized free block"
+ self setSizeOfFree: freeBlock to: self baseHeaderSize.
+ endOfMemory := freeBlock + self baseHeaderSize.
- self setSizeOfFree: freeBlock to: BaseHeaderSize.
- endOfMemory := freeBlock + BaseHeaderSize.
 
  "make a fake free chunk at endOfMemory for use as a sentinal in memory scans"
+ self setSizeOfFree: endOfMemory to: self baseHeaderSize.
- self setSizeOfFree: endOfMemory to: BaseHeaderSize.
 
  "use all memory free between freeBlock and memoryLimit for forwarding table"
  "Note: Forward blocks must be quadword aligned."
+ fwdTableNext := (endOfMemory + self baseHeaderSize + 7) bitAnd: self wordMask - 7.
- fwdTableNext := (endOfMemory + BaseHeaderSize + 7) bitAnd: WordMask-7.
  self flag: #Dan.  "Above line does not do what it says (quadword is 16 or 32 bytes)"
 
  fwdTableLast := memoryLimit - blkSize.  "last forwarding table entry"
 
  "return the number of forwarding blocks available"
  ^ (fwdTableLast - fwdTableNext) // blkSize  "round down"!

Item was changed:
  ----- Method: Interpreter>>primitiveFormPrint (in category 'I/O primitives') -----
  primitiveFormPrint
  "On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
 
  | landscapeFlag vScale hScale rcvr bitsArray w h
  depth pixelsPerWord wordsPerLine bitsArraySize ok |
 
  self var: #vScale type: 'double '.
  self var: #hScale type: 'double '.
  landscapeFlag := self booleanValueOf: self stackTop.
  vScale := self floatValueOf: (self stackValue: 1).
  hScale := self floatValueOf: (self stackValue: 2).
  rcvr := self stackValue: 3.
  (rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
  successFlag ifTrue: [
  ((self  isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4])
  ifFalse: [self success: false]].
  successFlag ifTrue: [
  bitsArray := self fetchPointer: 0 ofObject: rcvr.
  w := self fetchInteger: 1 ofObject: rcvr.
  h := self fetchInteger: 2 ofObject: rcvr.
  depth := self fetchInteger: 3 ofObject: rcvr.
  (w > 0 and: [h > 0]) ifFalse: [self success: false].
  pixelsPerWord := 32 // depth.
  wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord.
  ((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray])
  ifTrue: [
  bitsArraySize := self byteLengthOf: bitsArray.
  self success: (bitsArraySize = (wordsPerLine * h * 4))]
  ifFalse: [self success: false]].
  successFlag ifTrue: [
+ self bytesPerWord = 8
- BytesPerWord = 8
  ifTrue: [ok := self cCode: 'ioFormPrint(bitsArray + 8, w, h, depth, hScale, vScale, landscapeFlag)']
  ifFalse: [ok := self cCode: 'ioFormPrint(bitsArray + 4, w, h, depth, hScale, vScale, landscapeFlag)'].
  self success: ok].
  successFlag ifTrue: [
  self pop: 3].  "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"
  !

Item was changed:
  ----- Method: Interpreter>>restoreHeadersFrom:to:from:and:to:from: (in category 'image segment in/out') -----
  restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut
 
  "Restore headers smashed by forwarding links"
  | tablePtr oop header |
  tablePtr := firstIn.
  [self oop: tablePtr isLessThanOrEqualTo: lastIn] whileTrue:
  [oop := self longAt: tablePtr.
  header := self longAt: hdrBaseIn + (tablePtr-firstIn).
  self longAt: oop put: header.
+ tablePtr := tablePtr + self bytesPerWord].
- tablePtr := tablePtr + BytesPerWord].
  tablePtr := firstOut.
  [self oop: tablePtr isLessThanOrEqualTo: lastOut] whileTrue:
  [oop := self longAt: tablePtr.
  header := self longAt: hdrBaseOut + (tablePtr-firstOut).
  self longAt: oop put: header.
+ tablePtr := tablePtr + self bytesPerWord].
- tablePtr := tablePtr + BytesPerWord].
 
  "Clear all mark bits"
  oop := self firstObject.
  [self oop: oop isLessThan: endOfMemory] whileTrue:
  [(self isFreeObject: oop) ifFalse:
+ [self longAt: oop put: ((self longAt: oop) bitAnd: self allButMarkBit)].
- [self longAt: oop put: ((self longAt: oop) bitAnd: AllButMarkBit)].
  oop := self objectAfter: oop].
  !

Item was changed:
  ----- Method: Interpreter>>fetchIntegerOrTruncFloat:ofObject: (in category 'utilities') -----
  fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
  "Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
  "Note: May be called by translated primitive code."
 
  | intOrFloat floatVal frac trunc |
  self inline: false.
  self var: #floatVal type: 'double '.
  self var: #frac type: 'double '.
  self var: #trunc type: 'double '.
 
  intOrFloat := self fetchPointer: fieldIndex ofObject: objectPointer.
  (self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].
  self assertClassOf: intOrFloat is: (self splObj: ClassFloat).
  successFlag ifTrue: [
  self cCode: '' inSmalltalk: [floatVal := Float new: 2].
+ self fetchFloatAt: intOrFloat + self baseHeaderSize into: floatVal.
- self fetchFloatAt: intOrFloat + BaseHeaderSize into: floatVal.
  self cCode: 'frac = modf(floatVal, &trunc)'.
  "the following range check is for C ints, with range -2^31..2^31-1"
  self flag: #Dan. "The ranges are INCORRECT if SmallIntegers are wider than 31 bits."
  self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'.].
  successFlag
  ifTrue: [^ self cCode: '((sqInt) trunc)' inSmalltalk: [floatVal truncated]]
  ifFalse: [^ 0].
  !

Item was changed:
  ----- Method: ObjectMemory>>containOnlyOops:and: (in category 'become') -----
  containOnlyOops: array1 and: array2
  "Return true if neither array contains a small integer. You
  can't become: integers!!"
  | fieldOffset |
  fieldOffset := self lastPointerOf: array1.
  "same size as array2"
+ [fieldOffset >= self baseHeaderSize]
- [fieldOffset >= BaseHeaderSize]
  whileTrue: [(self isIntegerObject: (self longAt: array1 + fieldOffset)) ifTrue: [^ false].
  (self isIntegerObject: (self longAt: array2 + fieldOffset)) ifTrue: [^ false].
+ fieldOffset := fieldOffset - self bytesPerWord].
- fieldOffset := fieldOffset - BytesPerWord].
  ^ true!

Item was added:
+ ----- Method: ObjectMemory>>baseHeaderSize (in category 'constants') -----
+ baseHeaderSize
+ "Answer the size of an object memory header word in bytes."
+ "Class variable shadows the cpp macro definition in generated code."
+
+ self inline: true.
+ ^self cCode: 'BASE_HEADER_SIZE' inSmalltalk: [BaseHeaderSize]
+ !

Item was changed:
  ----- Method: ObjectMemory>>storeLong32:ofObject:withValue: (in category 'interpreter access') -----
  storeLong32: fieldIndex ofObject: oop withValue: valueWord
 
+ ^ self long32At: oop + self baseHeaderSize + (fieldIndex << 2)
- ^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2)
  put: valueWord!

Item was added:
+ ----- Method: InterpreterSimulator>>signalSemaphoreWithIndex: (in category 'memory access') -----
+ signalSemaphoreWithIndex: index
+ "Record the given semaphore index in the double buffer semaphores array to be signaled at the next convenient moment. Force a real interrupt check as soon as possible."
+
+ ^ index ifNotNil: [super signalSemaphoreWithIndex: index]!

Item was added:
+ ----- Method: ObjectMemory>>rootBit (in category 'constants') -----
+ rootBit
+ "Next-to-Top bit"
+
+ self inline: true.
+ ^self
+ cCode: 'ROOT_BIT'
+ inSmalltalk: [1 bitShift: BytesPerWord*8 - 2]
+ !

Item was added:
+ ----- Method: ObjectMemory>>allButMarkBitAndTypeMask (in category 'constants') -----
+ allButMarkBitAndTypeMask
+
+ self inline: true.
+ ^self
+ cCode: 'ALL_BUT_MARK_BIT_AND_TYPE_MASK'
+ inSmalltalk: [self allButTypeMask - self markBit]
+ !

Item was added:
+ ----- Method: ObjectMemory>>sizeMask (in category 'constants') -----
+ sizeMask
+ "One of the base header word bit fields. For 64-bit word size, lose the 4 bit
+ in temp 64-bit chunk format. See size4Bit, which restores the 4 bit ST size.
+ Note SizeMask + Size4Bit gives the mask needed for size fits of format word in classes.
+ This is used in instantiateClass:indexableSize: "
+
+ self inline: true.
+ ^self
+ cCode: 'SIZE_MASK'
+ inSmalltalk: [self bytesPerWord = 4
+ ifTrue: [16rFC]
+ ifFalse: [16rF8  "Lose the 4 bit in temp 64-bit chunk format"]]
+ !

Item was changed:
  ----- Method: Interpreter>>closureNumArgs:instructionPointer:numCopiedValues: (in category 'control primitives') -----
  closureNumArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
  | newClosure |
  self inline: true.
  newClosure := self
  instantiateSmallClass: (self splObj: ClassBlockClosure)
+ sizeInBytes: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize.
- sizeInBytes: (BytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + BaseHeaderSize.
  "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
  self storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (self integerObjectOf: initialIP).
  self storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (self integerObjectOf: numArgs).
  "It is up to the caller to store the outer context and copiedValues."
  ^newClosure!

Item was changed:
  ----- Method: Interpreter>>primitiveStoreStackp (in category 'object access primitives') -----
  primitiveStoreStackp
  "Atomic store into context stackPointer.
  Also ensures that any newly accessible cells are initialized to nil "
  | ctxt newStackp stackp |
  ctxt := self stackValue: 1.
  newStackp := self stackIntegerValue: 0.
  self success: (self oop: newStackp isGreaterThanOrEqualTo: 0).
+ self success: (self oop: newStackp isLessThanOrEqualTo: (self largeContextSize - self baseHeaderSize // self bytesPerWord - CtxtTempFrameStart)).
- self success: (self oop: newStackp isLessThanOrEqualTo: (LargeContextSize - BaseHeaderSize // BytesPerWord - CtxtTempFrameStart)).
  successFlag ifFalse: [^ self primitiveFail].
  stackp := self fetchStackPointerOf: ctxt.
  (self oop: newStackp isGreaterThan: stackp) ifTrue: ["Nil any newly accessible cells"
  stackp + 1 to: newStackp do: [:i | self storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: nilObj]].
  self storeStackPointerValue: newStackp inContext: ctxt.
  self pop: 1!

Item was changed:
  ----- Method: Interpreter>>primitiveBlockCopy (in category 'control primitives') -----
  primitiveBlockCopy
 
  | context methodContext contextSize newContext initialIP |
  context := self stackValue: 1.
  (self isIntegerObject: (self fetchPointer: MethodIndex ofObject: context))
  ifTrue: ["context is a block; get the context of its enclosing method"
  methodContext := self fetchPointer: HomeIndex ofObject: context]
  ifFalse: [methodContext := context].
  contextSize := self sizeBitsOf: methodContext.  "in bytes, including header"
  context := nil.  "context is no longer needed and is not preserved across allocation"
 
  "remap methodContext in case GC happens during allocation"
  self pushRemappableOop: methodContext.
  newContext := self instantiateContext: (self splObj: ClassBlockContext) sizeInBytes: contextSize.
  methodContext := self popRemappableOop.
 
+ initialIP := self integerObjectOf: (instructionPointer+1+3) - (method + self baseHeaderSize).
- initialIP := self integerObjectOf: (instructionPointer+1+3) - (method+BaseHeaderSize).
  "Was instructionPointer + 3, but now it's greater by 1 due to preIncrement"
 
  "Assume: have just allocated a new context; it must be young.
  Thus, can use uncheck stores. See the comment in fetchContextRegisters."
 
  self storePointerUnchecked: InitialIPIndex ofObject: newContext withValue: initialIP.
  self storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
  self storeStackPointerValue: 0 inContext: newContext.
  self storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0).
  self storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext.
  self storePointerUnchecked: SenderIndex ofObject: newContext withValue: nilObj.
 
  self pop: 2 thenPush: newContext.!

Item was changed:
  ----- Method: Interpreter>>internalFetchContextRegisters: (in category 'contexts') -----
  internalFetchContextRegisters: activeCntx
  "Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."
 
  | tmp |
  self inline: true.
  tmp := self fetchPointer: MethodIndex ofObject: activeCntx.
  (self isIntegerObject: tmp) ifTrue: [
  "if the MethodIndex field is an integer, activeCntx is a block context"
  tmp := self fetchPointer: HomeIndex ofObject: activeCntx.
  (self oop: tmp isLessThan: youngStart) ifTrue: [ self beRootIfOld: tmp ].
  ] ifFalse: [
  "otherwise, it is a method context and is its own home context"
  tmp := activeCntx.
  ].
  localHomeContext := tmp.
  receiver := self fetchPointer: ReceiverIndex ofObject: tmp.
  method := self fetchPointer: MethodIndex ofObject: tmp.
 
  "the instruction pointer is a pointer variable equal to
+ method oop + ip + self baseHeaderSize
- method oop + ip + BaseHeaderSize
   -1 for 0-based addressing of fetchByte
   -1 because it gets incremented BEFORE fetching currentByte"
  tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
+ localIP := self pointerForOop: method + tmp + self baseHeaderSize - 2.
- localIP := self pointerForOop: method + tmp + BaseHeaderSize - 2.
 
  "the stack pointer is a pointer variable also..."
  tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
+ localSP := self pointerForOop: activeCntx + self baseHeaderSize + ((TempFrameStart + tmp - 1) * self bytesPerWord)!
- localSP := self pointerForOop: activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * BytesPerWord)!

Item was changed:
  ----- Method: Interpreter>>primitiveGetAttribute (in category 'system control primitives') -----
  primitiveGetAttribute
  "Fetch the system attribute with the given integer ID. The
  result is a string, which will be empty if the attribute is not
  defined."
  | attr sz s |
  attr := self stackIntegerValue: 0.
  successFlag
  ifTrue: [sz := self attributeSize: attr].
  successFlag
  ifTrue: [s := self
  instantiateClass: (self splObj: ClassString)
  indexableSize: sz.
  self
  getAttribute: attr
+ Into: s + self baseHeaderSize
- Into: s + BaseHeaderSize
  Length: sz.
  self pop: 2 thenPush: s]!

Item was changed:
  ----- Method: ObjectMemory>>fetchClassOfNonInt: (in category 'interpreter access') -----
  fetchClassOfNonInt: oop
  | ccIndex |
  self inline: true.
  ccIndex := (self baseHeader: oop) >> 12 bitAnd: 31.
  ccIndex = 0
  ifTrue: [^ (self classHeader: oop)
+ bitAnd: self allButTypeMask]
- bitAnd: AllButTypeMask]
  ifFalse: ["look up compact class"
  ^ self fetchPointer: ccIndex - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)]!

Item was changed:
  ----- Method: Interpreter>>activateNewClosureMethod: (in category 'control primitives') -----
  activateNewClosureMethod: blockClosure
  "Similar to activateNewMethod but for Closure and newMethod."
  | theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |
 
  DoAssertionChecks ifTrue:
  [self okayOop: blockClosure].
  outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
  DoAssertionChecks ifTrue:
  [self okayOop: outerContext].
  closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
  methodHeader := self headerOf: closureMethod.
  self pushRemappableOop: blockClosure.
  newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
 
  "allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al"
  theBlockClosure := self popRemappableOop.
  outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure.
  numCopied := (self fetchWordLengthOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
 
  "Assume: newContext will be recorded as a root if necessary by the
  call to newActiveContext: below, so we can use unchecked stores."
+ where :=  newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord)
- where :=  newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord)
  put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord)
- self longAt: where + (InstructionPointerIndex << ShiftForWord)
  put: (self fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure).
+ self longAt: where + (StackPointerIndex << self shiftForWord)
- self longAt: where + (StackPointerIndex << ShiftForWord)
  put: (self integerObjectOf: argumentCount + numCopied).
+ self longAt: where + (MethodIndex << self shiftForWord)
- self longAt: where + (MethodIndex << ShiftForWord)
  put: (self fetchPointer: MethodIndex ofObject: outerContext).
+ self longAt: where + (ClosureIndex << self shiftForWord)
- self longAt: where + (ClosureIndex << ShiftForWord)
  put: theBlockClosure.
+ self longAt: where + (ReceiverIndex << self shiftForWord)
- self longAt: where + (ReceiverIndex << ShiftForWord)
  put: (self fetchPointer: ReceiverIndex ofObject: outerContext).
 
  "Copy the arguments..."
  1 to: argumentCount do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord)
- [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord)
  put: (self stackValue: argumentCount-i)].
 
  "Copy the copied values..."
+ where := newContext + self baseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << self shiftForWord).
- where := newContext + BaseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << ShiftForWord).
  0 to: numCopied - 1 do:
+ [:i| self longAt: where + (i << self shiftForWord)
- [:i| self longAt: where + (i << ShiftForWord)
  put: (self fetchPointer: i + ClosureFirstCopiedValueIndex
   ofObject: theBlockClosure)].
 
  "The initial instructions in the block nil-out remaining temps."
 
  self pop: argumentCount + 1.
  self newActiveContext: newContext!

Item was changed:
  ----- Method: Interpreter>>primitiveIsRoot (in category 'memory space primitives') -----
  primitiveIsRoot
  "Primitive. Answer whether the argument to the primitive is a root for young space"
  | oop |
  self export: true.
  oop := self stackObjectValue: 0.
  successFlag ifTrue:[
  self pop: argumentCount + 1.
+ self pushBool: ((self baseHeader: oop) bitAnd: self rootBit).
- self pushBool: ((self baseHeader: oop) bitAnd: RootBit).
  ].!

Item was changed:
  ----- Method: ObjectMemory>>noteAsRoot:headerLoc: (in category 'garbage collection') -----
  noteAsRoot: oop headerLoc: headerLoc
  "Record that the given oop in the old object area points to an
  object in the young area.
  HeaderLoc is usually = oop, but may be an addr in a
  forwarding block."
  | header |
  self inline: true.
  header := self longAt: headerLoc.
+ (header bitAnd: self rootBit) = 0
- (header bitAnd: RootBit) = 0
  ifTrue: ["record oop as root only if not already recorded"
  rootTableCount < RootTableRedZone
  ifTrue: ["record root if there is enough room in the roots
  table "
  rootTableCount := rootTableCount + 1.
  rootTable at: rootTableCount put: oop.
+ self longAt: headerLoc put: (header bitOr: self rootBit)]
- self longAt: headerLoc put: (header bitOr: RootBit)]
  ifFalse: ["we're getting in the red zone"
  rootTableCount < RootTableSize
  ifTrue: ["but there's still space to record it"
  rootTableCount := rootTableCount + 1.
  rootTable at: rootTableCount put: oop.
+ self longAt: headerLoc put: (header bitOr: self rootBit).
- self longAt: headerLoc put: (header bitOr: RootBit).
  "but force an IGC on the next allocation"
  allocationCount := allocationsBetweenGCs + 1]]]!

Item was changed:
  ----- Method: Interpreter>>transfer:from:to: (in category 'utilities') -----
  transfer: count from: src to: dst
  | in out lastIn |
  self flag: #Dan.  "Need to check all senders before converting this for 64 bits"
  self inline: true.
+ in := src - self bytesPerWord.
+ lastIn := in + (count * self bytesPerWord).
+ out := dst - self bytesPerWord.
- in := src - BytesPerWord.
- lastIn := in + (count * BytesPerWord).
- out := dst - BytesPerWord.
  [self oop: in isLessThan: lastIn]
  whileTrue: [self
+ longAt: (out := out + self bytesPerWord)
+ put: (self longAt: (in := in + self bytesPerWord))]!
- longAt: (out := out + BytesPerWord)
- put: (self longAt: (in := in + BytesPerWord))]!

Item was changed:
  ----- Method: CCodeGenerator>>generateBaseHeaderSize:on:indent: (in category 'C translation') -----
  generateBaseHeaderSize: msgNode on: aStream indent: level
  "Generate the C code for this message onto the given stream."
 
+ aStream nextPutAll: 'BASE_HEADER_SIZE'
+
- aStream nextPutAll: ' ', ObjectMemory baseHeaderSize asString
  !

Item was changed:
  ----- Method: Interpreter>>fetchContextRegisters: (in category 'contexts') -----
  fetchContextRegisters: activeCntx
  "Note: internalFetchContextRegisters: should track changes  to this method."
  | tmp |
  self inline: true.
  tmp := self fetchPointer: MethodIndex ofObject: activeCntx.
  (self isIntegerObject: tmp)
  ifTrue: ["if the MethodIndex field is an integer, activeCntx is a block context"
  tmp := self fetchPointer: HomeIndex ofObject: activeCntx.
  (self oop: tmp isLessThan: youngStart) ifTrue: [self beRootIfOld: tmp]]
  ifFalse: ["otherwise, it is a method context and is its own home context "
  tmp := activeCntx].
  theHomeContext := tmp.
  receiver := self fetchPointer: ReceiverIndex ofObject: tmp.
  method := self fetchPointer: MethodIndex ofObject: tmp.
 
  "the instruction pointer is a pointer variable equal to
+ method oop + ip + self baseHeaderSize
- method oop + ip + BaseHeaderSize
  -1 for 0-based addressing of fetchByte
  -1 because it gets incremented BEFORE fetching currentByte "
  tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
+ instructionPointer := method + tmp + self baseHeaderSize - 2.
- instructionPointer := method + tmp + BaseHeaderSize - 2.
 
  "the stack pointer is a pointer variable also..."
  tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
+ stackPointer := activeCntx + self baseHeaderSize + (TempFrameStart + tmp - 1 * self bytesPerWord)!
- stackPointer := activeCntx + BaseHeaderSize + (TempFrameStart + tmp - 1 * BytesPerWord)!

Item was changed:
  ----- Method: InterpreterSimulator>>dumpHeader: (in category 'debug support') -----
  dumpHeader: hdr
  | cc |
  ^ String streamContents: [:strm |
  cc := (hdr bitAnd: CompactClassMask) >> 12.
  strm nextPutAll: '<cc=', cc hex.
  cc > 0 ifTrue:
  [strm nextPutAll: ':' , (self nameOfClass: (self compactClassAt: cc))].
  strm nextPutAll: '>'.
  strm nextPutAll: '<ft=', ((hdr bitShift: -8) bitAnd: 16rF) hex , '>'.
+ strm nextPutAll: '<sz=', (hdr bitAnd: self sizeMask) hex , '>'.
- strm nextPutAll: '<sz=', (hdr bitAnd: SizeMask) hex , '>'.
  strm nextPutAll: '<hdr=', (#(big class gcMark short) at: (hdr bitAnd: 3) +1) , '>']
  !

Item was changed:
  ----- Method: Interpreter>>stackIntegerValue: (in category 'contexts') -----
  stackIntegerValue: offset
  | integerPointer |
+ integerPointer := self longAt: stackPointer - (offset * self bytesPerWord).
- integerPointer := self longAt: stackPointer - (offset*BytesPerWord).
  ^self checkedIntegerValueOf: integerPointer!

Item was changed:
  ----- Method: Interpreter>>primitiveNewMethod (in category 'compiled methods') -----
  primitiveNewMethod
  | header bytecodeCount class size theMethod literalCount |
  header := self popStack.
  bytecodeCount := self popInteger.
  self success: (self isIntegerObject: header).
  successFlag ifFalse:
  [self unPop: 2. ^nil].
  class := self popStack.
+ size := (self literalCountOfHeader: header) + 1 * self bytesPerWord + bytecodeCount.
- size := (self literalCountOfHeader: header) + 1 * BytesPerWord + bytecodeCount.
  theMethod := self instantiateClass: class indexableSize: size.
  self storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header.
  literalCount := self literalCountOfHeader: header.
  1 to: literalCount do:
  [:i | self storePointer: i ofObject: theMethod withValue: nilObj].
  self push: theMethod!

Item was changed:
  ----- Method: Interpreter>>primitiveImageName (in category 'other primitives') -----
  primitiveImageName
  "When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name."
 
  | s sz sCRIfn okToRename |
  self var: #sCRIfn type: 'void *'.
  argumentCount = 1 ifTrue: [
  "If the security plugin can be loaded, use it to check for rename permission.
  If not, assume it's ok"
  sCRIfn := self ioLoadFunction: 'secCanRenameImage' From: 'SecurityPlugin'.
  sCRIfn ~= 0 ifTrue:[okToRename := self cCode:' ((sqInt (*)(void))sCRIfn)()'.
  okToRename ifFalse:[^self primitiveFail]].
  s := self stackTop.
  self assertClassOf: s is: (self splObj: ClassString).
  successFlag ifTrue: [
  sz := self stSizeOf: s.
+ self imageNamePut: (s + self baseHeaderSize) Length: sz.
- self imageNamePut: (s + BaseHeaderSize) Length: sz.
  self pop: 1.  "pop s, leave rcvr on stack"
  ].
  ] ifFalse: [
  sz := self imageNameSize.
  s := self instantiateClass: (self splObj: ClassString) indexableSize: sz.
+ self imageNameGet: (s + self baseHeaderSize) Length: sz.
- self imageNameGet: (s + BaseHeaderSize) Length: sz.
  self pop: 1.  "rcvr"
  self push: s.
  ].
  !

Item was changed:
  ----- Method: Interpreter>>snapshotCleanUp (in category 'image save/restore') -----
  snapshotCleanUp
  "Clean up right before saving an image, sweeping memory and:
  * nilling out all fields of contexts above the stack pointer.
  * flushing external primitives
  * clearing the root bit of any object in the root table "
  | oop header fmt sz |
  oop := self firstObject.
  [self oop: oop isLessThan: endOfMemory]
  whileTrue: [(self isFreeObject: oop)
  ifFalse: [header := self longAt: oop.
  fmt := header >> 8 bitAnd: 15.
  "Clean out context"
  (fmt = 3 and: [self isContextHeader: header])
  ifTrue: [sz := self sizeBitsOf: oop.
+ (self lastPointerOf: oop) + self bytesPerWord
+ to: sz - self baseHeaderSize by: self bytesPerWord
- (self lastPointerOf: oop) + BytesPerWord
- to: sz - BaseHeaderSize by: BytesPerWord
  do: [:i | self longAt: oop + i put: nilObj]].
  "Clean out external functions"
  fmt >= 12
  ifTrue: ["This is a compiled method"
  (self primitiveIndexOf: oop) = PrimitiveExternalCallIndex
  ifTrue: ["It's primitiveExternalCall"
  self flushExternalPrimitiveOf: oop]]].
  oop := self objectAfter: oop].
  self clearRootsTable!

Item was changed:
  ----- Method: ObjectMemory>>rightType: (in category 'header access') -----
  rightType: headerWord
  "Compute the correct header type for an object based on the size and compact class fields of the given base header word, rather than its type bits. This is used during marking, when the header type bits are used to record the state of tracing."
 
+ (headerWord bitAnd: self sizeMask) = 0  "zero size field in header word"
- (headerWord bitAnd: SizeMask) = 0  "zero size field in header word"
  ifTrue: [ ^HeaderTypeSizeAndClass ]
  ifFalse: [ (headerWord bitAnd: CompactClassMask) = 0
  ifTrue: [ ^HeaderTypeClass ]
  ifFalse: [ ^HeaderTypeShort ]].!

Item was changed:
  ----- Method: Interpreter>>firstIndexableField: (in category 'plugin support') -----
  firstIndexableField: oop
  "NOTE: copied in InterpreterSimulator, so please duplicate any changes"
 
  | hdr fmt totalLength fixedFields |
  self returnTypeC: 'char *'.
  hdr := self baseHeader: oop.
  fmt := (hdr >> 8) bitAnd: 16rF.
  totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
  fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
  fmt < 8 ifTrue:
  [fmt = 6 ifTrue:
  ["32 bit field objects"
+ ^ self pointerForOop: oop + self baseHeaderSize + (fixedFields << 2)].
- ^ self pointerForOop: oop + BaseHeaderSize + (fixedFields << 2)].
  "full word objects (pointer or bits)"
+ ^ self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)]
- ^ self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)]
  ifFalse:
  ["Byte objects"
+ ^ self pointerForOop: oop + self baseHeaderSize + fixedFields]!
- ^ self pointerForOop: oop + BaseHeaderSize + fixedFields]!

Item was changed:
  ----- Method: Interpreter>>primitiveShortAt (in category 'array primitives') -----
  primitiveShortAt
  "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
 
  | index rcvr sz addr value |
  index := self stackIntegerValue: 0.
  rcvr := self stackValue: 1.
  self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
  successFlag ifFalse: [ ^ nil ].
+ sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2.  "number of 16-bit fields"
- sz := ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2.  "number of 16-bit fields"
  self success: ((index >= 1) and: [index <= sz]).
  successFlag ifTrue: [
+ addr := rcvr + self baseHeaderSize + (2 * (index - 1)).
- addr := rcvr + BaseHeaderSize + (2 * (index - 1)).
  value := self shortAt: addr.
  self pop: 2 thenPushInteger: value.
  ]!

Item was changed:
  ----- Method: Interpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'alien support') -----
  sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
  "Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
  to Alien class with the supplied args.  The arguments are raw C addresses
  and are converted to integer objects on the way."
  | where |
  self export: true.
  self pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr).
  self pushRemappableOop: (self positive32BitIntegerFor: regsPtr).
  self pushRemappableOop: (self positive32BitIntegerFor: stackPtr).
  self pushRemappableOop: (self positive32BitIntegerFor: thunkPtr).
  receiver := self splObj: ClassAlien.
  lkupClass := self fetchClassOfNonInt: receiver.
  messageSelector := self splObj: InvokeCallbackSelector.
  (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
  [(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse:
  [^false]].
  primitiveIndex ~= 0 ifTrue:
  [^false].
  self storeContextRegisters: activeContext.
  self internalJustActivateNewMethod.
+ where := activeContext + self baseHeaderSize + (ReceiverIndex << self shiftForWord).
+ self longAt: where + (1 << self shiftForWord) put: self popRemappableOop.
+ self longAt: where + (2 << self shiftForWord) put: self popRemappableOop.
+ self longAt: where + (3 << self shiftForWord) put: self popRemappableOop.
+ self longAt: where + (4 << self shiftForWord) put: self popRemappableOop.
- where := activeContext + BaseHeaderSize + (ReceiverIndex << ShiftForWord).
- self longAt: where + (1 << ShiftForWord) put: self popRemappableOop.
- self longAt: where + (2 << ShiftForWord) put: self popRemappableOop.
- self longAt: where + (3 << ShiftForWord) put: self popRemappableOop.
- self longAt: where + (4 << ShiftForWord) put: self popRemappableOop.
  self fetchContextRegisters: activeContext.
  self callInterpreter.
  "not reached"
  ^true!

Item was changed:
  ----- Method: ObjectMemory>>initializeMemoryFirstFree: (in category 'initialization') -----
  initializeMemoryFirstFree: firstFree
  "Initialize endOfMemory to the top of oop storage space, reserving some space for forwarding blocks, and create the freeBlock from which space is allocated. Also create a fake free chunk at endOfMemory to act as a sentinal for memory scans. "
  "Note: The amount of space reserved for forwarding blocks should be chosen to ensure that incremental compactions can usually be done in a single pass. However, there should be enough forwarding blocks so a full compaction can be done in a reasonable number of passes, say ten. (A full compaction requires N object-moving passes, where N = number of non-garbage objects / number of forwarding blocks).
  di 11/18/2000 Re totalObjectCount: Provide a margin of one byte per object to be used for forwarding pointers at GC time. Since fwd blocks are 8 bytes, this means an absolute worst case of 8 passes to compact memory. In most cases it will be adequate to do compaction in a single pass. "
  | fwdBlockBytes |
  self var: #firstFree type: 'usqInt'.
  self var: #fwdBlockBytes type: 'usqInt'.
  "reserve space for forwarding blocks"
+ fwdBlockBytes := totalObjectCount bitAnd: self wordMask - self bytesPerWord + 1.
+ (self oop: memoryLimit - fwdBlockBytes isGreaterThanOrEqualTo: firstFree + self baseHeaderSize)
- fwdBlockBytes := totalObjectCount bitAnd: WordMask - BytesPerWord + 1.
- (self oop: memoryLimit - fwdBlockBytes isGreaterThanOrEqualTo: firstFree + BaseHeaderSize)
  ifFalse: ["reserve enough space for a minimal free block of BaseHeaderSize bytes"
+ fwdBlockBytes := memoryLimit - (firstFree + self baseHeaderSize)].
- fwdBlockBytes := memoryLimit - (firstFree + BaseHeaderSize)].
 
  "set endOfMemory and initialize freeBlock"
  endOfMemory := memoryLimit - fwdBlockBytes.
  freeBlock := firstFree.
  self setSizeOfFree: freeBlock to: endOfMemory - firstFree. "bytes available for oops"
 
  "make a fake free chunk at endOfMemory for use as a sentinel in memory scans"
+ self setSizeOfFree: endOfMemory to: self baseHeaderSize.
- self setSizeOfFree: endOfMemory to: BaseHeaderSize.
  DoAssertionChecks
  ifTrue: [(freeBlock < endOfMemory and: [endOfMemory < memoryLimit])
  ifFalse: [self error: 'error in free space computation'].
  (self oopFromChunk: endOfMemory) = endOfMemory
  ifFalse: [self error: 'header format must have changed'].
  (self objectAfter: freeBlock) = endOfMemory
  ifFalse: [self error: 'free block not properly initialized']]!

Item was changed:
  ----- Method: Interpreter>>internalPop: (in category 'contexts') -----
  internalPop: nItems
 
+ localSP := localSP - (nItems * self bytesPerWord).!
- localSP := localSP - (nItems * BytesPerWord).!

Item was changed:
  ----- Method: ObjectMemory>>sizeHeader: (in category 'header access') -----
  sizeHeader: oop
 
+ ^ self longAt: oop - (self bytesPerWord * 2)!
- ^ self longAt: oop - (BytesPerWord*2)!

Item was changed:
  ----- Method: InterpreterSimulator>>validateOopsIn: (in category 'testing') -----
  validateOopsIn: object
  | fieldPtr limit former header |
  "for each oop in me see if it is legal"
  fieldPtr := object + BaseHeaderSize. "first field"
  limit := object + (self lastPointerOf: object). "a good field"
  [fieldPtr > limit] whileFalse: [
  former := self longAt: fieldPtr.
  (self validOop: former) ifFalse: [self error: 'invalid oop in pointers object'].
  fieldPtr := fieldPtr + BytesPerWord].
  "class"
  header := self baseHeader: object.
  (header bitAnd: CompactClassMask) = 0 ifTrue: [
+ former := (self classHeader: object) bitAnd: self allButTypeMask.
- former := (self classHeader: object) bitAnd: AllButTypeMask.
  (self validOop: former) ifFalse: [self halt]].!

Item was added:
+ ----- Method: ArrayedCollection>>swapBytesFrom:to: (in category '*VMMaker-simulated image growing') -----
+ swapBytesFrom: start to: stop
+ "Perform a bigEndian/littleEndian byte reversal of my words.
+ We only intend this for non-pointer arrays.  Do nothing if I contain pointers."
+ | hack blt |
+
+ self class isPointers | self class isWords not ifTrue: [^ self].
+
+ "The implementation is a hack, but fast for large ranges"
+ hack := Form new hackBits: self.
+ blt := (BitBlt toForm: hack) sourceForm: hack.
+ blt combinationRule: Form reverse.  "XOR"
+ blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1.
+ blt sourceX: 0; destX: 3; copyBits.  "Exchange bytes 0 and 3"
+ blt sourceX: 3; destX: 0; copyBits.
+ blt sourceX: 0; destX: 3; copyBits.
+ blt sourceX: 1; destX: 2; copyBits.  "Exchange bytes 1 and 2"
+ blt sourceX: 2; destX: 1; copyBits.
+ blt sourceX: 1; destX: 2; copyBits.
+ !

Item was changed:
  ----- Method: Interpreter>>changeClassOf:to: (in category 'object access primitives') -----
  changeClassOf: rcvr to: argClass
  "Change the class of the receiver into the class specified by the argument given that the format of the receiver matches the format of the argument. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
  | classHdr sizeHiBits byteSize argFormat rcvrFormat ccIndex |
  "Check what the format of the class says"
  classHdr := self formatOfClass: argClass. "Low 2 bits are 0"
 
  "Compute the size of instances of the class (used for fixed field classes only)"
  sizeHiBits := (classHdr bitAnd: 16r60000) >> 9.
  classHdr := classHdr bitAnd: 16r1FFFF.
+ byteSize := (classHdr bitAnd: self sizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
- byteSize := (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
 
  "Check the receiver's format against that of the class"
  argFormat := (classHdr >> 8) bitAnd: 16rF.
  rcvrFormat := self formatOf: rcvr.
  argFormat = rcvrFormat ifFalse:[^self primitiveFail]. "no way"
 
  "For fixed field classes, the sizes must match.
  Note: byteSize-4 because base header is included in class size."
+ argFormat < 2 ifTrue:[(byteSize - self baseHeaderSize) = (self byteSizeOf: rcvr) ifFalse:[^self primitiveFail]].
- argFormat < 2 ifTrue:[(byteSize - BaseHeaderSize) = (self byteSizeOf: rcvr) ifFalse:[^self primitiveFail]].
 
  (self headerType: rcvr) = HeaderTypeShort
  ifTrue:[ "Compact classes. Check if the arg's class is compact and exchange ccIndex"
  ccIndex := classHdr bitAnd: CompactClassMask.
  ccIndex = 0 ifTrue:[^self primitiveFail]. "class is not compact"
  self longAt: rcvr put:
  (((self longAt: rcvr) bitAnd: CompactClassMask bitInvert32)
  bitOr: ccIndex)]
  ifFalse:["Exchange the class pointer, which could make rcvr a root for argClass"
+ self longAt: rcvr - self baseHeaderSize put: (argClass bitOr: (self headerType: rcvr)).
- self longAt: rcvr-BaseHeaderSize put: (argClass bitOr: (self headerType: rcvr)).
  (self oop: rcvr isLessThan: youngStart)
  ifTrue: [self possibleRootStoreInto: rcvr value: argClass]].
 
  "Flush cache because rcvr's class has changed"
  self flushMethodCache.
  !

Item was added:
+ ----- Method: ObjectMemory>>markBit (in category 'constants') -----
+ markBit
+ "Top bit"
+
+ self inline: true.
+ ^self
+ cCode: 'MARK_BIT'
+ inSmalltalk: [1 bitShift: self bytesPerWord*8 - 1]
+ !

Item was changed:
  ----- Method: Interpreter>>imageFormatBackwardCompatibilityVersion (in category 'image save/restore') -----
  imageFormatBackwardCompatibilityVersion
  "This VM is backwards-compatible with the immediately preceeding pre-closure version, and will allow loading images (or image segments) of that version."
 
+ self bytesPerWord == 4
- BytesPerWord == 4
  ifTrue: [^6502]
  ifFalse: [^68000]!

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.
 
  "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.
- AllButHashBits := WordMask - HashBits.
  HashBitsOffset := 17.
- 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.
- CompactClassMask := 16r1F000.
 
+ 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.!

Item was added:
+ ----- Method: ObjectMemory>>longSizeMask (in category 'constants') -----
+ longSizeMask
+ "One of the base header word bit fields. For 64-bit word size, lose
+ the 4 bit in temp 64-bit chunk format."
+
+ self inline: true.
+ ^self
+ cCode: 'LONG_SIZE_MASK'
+ inSmalltalk: [self wordMask - 16rFF + self sizeMask]
+ !

Item was added:
+ ----- Method: ObjectMemory>>size4Bit (in category 'constants') -----
+ size4Bit
+ "One of the base header word bit fields. The 4 bit is excluded from sizeMask for
+ 64-bit object memory, 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: "
+
+ self inline: true.
+ ^self
+ cCode: 'SIZE_4_BIT'
+ inSmalltalk: [self bytesPerWord = 4
+ ifTrue: [0]
+ ifFalse: [4]]
+ !

Item was changed:
  ----- Method: InterpreterSimulator>>firstIndexableField: (in category 'memory access') -----
  firstIndexableField: oop
  "NOTE: overridden from Interpreter to add coercion to CArray"
 
  | hdr fmt totalLength fixedFields |
  self returnTypeC: 'void *'.
  hdr := self baseHeader: oop.
  fmt := (hdr >> 8) bitAnd: 16rF.
  totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
  fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
  fmt < 8 ifTrue:
  [fmt = 6 ifTrue:
  ["32 bit field objects"
  ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << 2)) to: 'int *'].
  "full word objects (pointer or bits)"
+ ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *']
- ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)) to: 'oop *']
  ifFalse:
  ["Byte objects"
  ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + fixedFields) to: 'char *']!

Item was changed:
  ----- Method: ObjectMemory>>objectAfterWhileForwarding: (in category 'gc -- compaction') -----
  objectAfterWhileForwarding: oop
  "Return the oop of the object after the given oop when the actual header of the oop may be in the forwarding table."
 
  | header fwdBlock realHeader sz |
  self inline: true.
  header := self longAt: oop.
+ (header bitAnd: self markBit) = 0 ifTrue: [ ^ self objectAfter: oop ].  "oop not forwarded"
- (header bitAnd: MarkBit) = 0 ifTrue: [ ^ self objectAfter: oop ].  "oop not forwarded"
 
  "Assume: mark bit cannot be set on a free chunk, so if we get here,
  oop is not free and it has a forwarding table entry"
 
+ fwdBlock := (header bitAnd: self allButMarkBitAndTypeMask) << 1.
- fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
  DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
+ realHeader := self longAt: fwdBlock + self bytesPerWord.
- realHeader := self longAt: fwdBlock + BytesPerWord.
  "following code is like sizeBitsOf:"
  (realHeader bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self longSizeMask ]
+ ifFalse: [ sz := realHeader bitAnd: self sizeMask ].
- ifTrue: [ sz := (self sizeHeader: oop) bitAnd: LongSizeMask ]
- ifFalse: [ sz := realHeader bitAnd: SizeMask ].
 
  ^ self oopFromChunk: (oop + sz)!

Item was changed:
  ----- Method: Interpreter>>floatObjectOf: (in category 'object format') -----
  floatObjectOf: aFloat
  | newFloatObj |
  self flag: #Dan.
  self var: #aFloat type: 'double '.
+ newFloatObj := self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8 + self baseHeaderSize.
+ self storeFloatAt: newFloatObj + self baseHeaderSize from: aFloat.
- newFloatObj := self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8+BaseHeaderSize.
- self storeFloatAt: newFloatObj + BaseHeaderSize from: aFloat.
  ^ newFloatObj.
  !

Item was changed:
  ----- Method: Interpreter>>internalJustActivateNewMethod (in category 'message sending') -----
  internalJustActivateNewMethod
  "Activate the new method but *do not* copy receiver or argumernts from activeContext."
  | methodHeader initialIP newContext tempCount needsLarge where |
  self inline: true.
 
  methodHeader := self headerOf: newMethod.
  needsLarge := methodHeader bitAnd: LargeContextBit.
  (needsLarge = 0 and: [freeContexts ~= NilContext])
  ifTrue: [newContext := freeContexts.
  freeContexts := self fetchPointer: 0 ofObject: newContext]
  ifFalse: ["Slower call for large contexts or empty free list"
  newContext := self allocateOrRecycleContext: needsLarge].
+ initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1.
- initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * BytesPerWord) + 1.
  tempCount := (methodHeader >> 19) bitAnd: 16r3F.
 
  "Assume: newContext will be recorded as a root if necessary by the
  call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
+ self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
- where := newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf: initialIP).
- self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.
 
  "Set the receiver..."
+ self longAt: where + (ReceiverIndex << self shiftForWord) put: receiver.
- self longAt: where + (ReceiverIndex << ShiftForWord) put: receiver.
 
  "clear all args and temps to nil in case it has been recycled"
  needsLarge := nilObj.  "needsLarge here used just as faster (register?) temp"
  ReceiverIndex + 1 to: tempCount + ReceiverIndex do:
+ [:i | self longAt: where + (i << self shiftForWord) put: needsLarge].
- [:i | self longAt: where + (i << ShiftForWord) put: needsLarge].
  reclaimableContextCount := reclaimableContextCount + 1.
 
  activeContext := newContext.!

Item was changed:
  ----- Method: Interpreter>>primitiveInvokeObjectAsMethod (in category 'control primitives') -----
  primitiveInvokeObjectAsMethod
  "Primitive. 'Invoke' an object like a function, sending the special message
  run: originalSelector with: arguments in: aReceiver.
  "
  | runSelector runReceiver runArgs newReceiver lookupClass |
  runArgs := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
  self beRootIfOld: runArgs. "do we really need this?"
+ self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * self bytesPerWord) to: runArgs + self baseHeaderSize.
- self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * BytesPerWord) to: runArgs + BaseHeaderSize.
 
  runSelector := messageSelector.
  runReceiver := self stackValue: argumentCount.
  self pop: argumentCount+1.
 
  "stack is clean here"
 
  newReceiver := newMethod.
  messageSelector := self splObj: SelectorRunWithIn.
  argumentCount := 3.
 
  self push: newReceiver.
  self push: runSelector.
  self push: runArgs.
  self push: runReceiver.
 
  lookupClass := self fetchClassOf: newReceiver.
  self findNewMethodInClass: lookupClass.
  self executeNewMethodFromCache.  "Recursive xeq affects successFlag"
  successFlag := true.
  !

Item was changed:
  ----- Method: ObjectMemory>>fetchByte:ofObject: (in category 'interpreter access') -----
  fetchByte: byteIndex ofObject: oop
 
+ ^ self byteAt: oop + self baseHeaderSize + byteIndex!
- ^ self byteAt: oop + BaseHeaderSize + byteIndex!

Item was changed:
  ----- Method: ObjectMemory>>incCompMakeFwd (in category 'gc -- compaction') -----
  incCompMakeFwd
  "Create and initialize forwarding blocks for all non-free objects  
  following compStart. If the supply of forwarding blocks is exhausted,  
  set compEnd to the first chunk above the area to be
  compacted; otherwise, set it to endOfMemory. Return the number of
  bytes to be freed."
  | bytesFreed oop fwdBlock newOop |
  self inline: false.
  bytesFreed := 0.
  oop := self oopFromChunk: compStart.
  [self oop: oop isLessThan: endOfMemory]
  whileTrue: [
  statMkFwdCount := statMkFwdCount + 1.
  (self isFreeObject: oop)
  ifTrue: [bytesFreed := bytesFreed + (self sizeOfFree: oop)]
  ifFalse: ["create a forwarding block for oop"
+ fwdBlock := self fwdBlockGet: self bytesPerWord * 2.
- fwdBlock := self fwdBlockGet: BytesPerWord*2.
  "Two-word block"
  fwdBlock = nil
  ifTrue: ["stop; we have used all available forwarding blocks"
  compEnd := self chunkFromOop: oop.
  ^ bytesFreed].
  newOop := oop - bytesFreed.
  self initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: false].
  oop := self objectAfterWhileForwarding: oop].
  compEnd := endOfMemory.
  ^ bytesFreed!

Item was changed:
  ----- Method: Interpreter>>primitiveClipboardText (in category 'I/O primitives') -----
  primitiveClipboardText
  "When called with a single string argument, post the string to
  the clipboard. When called with zero arguments, return a
  string containing the current clipboard contents."
  | s sz |
  argumentCount = 1
  ifTrue: [s := self stackTop.
  (self isBytes: s) ifFalse: [^ self primitiveFail].
  successFlag
  ifTrue: [sz := self stSizeOf: s.
+ self clipboardWrite: sz From: s + self baseHeaderSize At: 0.
- self clipboardWrite: sz From: s + BaseHeaderSize At: 0.
  self pop: 1]]
  ifFalse: [sz := self clipboardSize.
  (self sufficientSpaceToAllocate: sz) ifFalse:[^self primitiveFail].
  s := self instantiateClass: (self splObj: ClassString) indexableSize: sz.
+ self clipboardRead: sz Into: s + self baseHeaderSize At: 0.
- self clipboardRead: sz Into: s + BaseHeaderSize At: 0.
  self pop: 1 thenPush: s]!

Item was changed:
  ----- Method: Interpreter>>primitiveConstantFill (in category 'array primitives') -----
  primitiveConstantFill
  "Fill the receiver, which must be an indexable bytes or words
  objects, with the given integer value."
  | fillValue rcvr rcvrIsBytes end i |
  self var: #end type: 'usqInt'.
  self var: #i type: 'usqInt'.
  fillValue := self positive32BitValueOf: self stackTop.
  rcvr := self stackValue: 1.
  self success: (self isWordsOrBytes: rcvr).
  rcvrIsBytes := self isBytes: rcvr.
  rcvrIsBytes ifTrue: [self success: (fillValue >= 0 and: [fillValue <= 255])].
  successFlag
  ifTrue: [end := rcvr + (self sizeBitsOf: rcvr).
+ i := rcvr + self baseHeaderSize.
- i := rcvr + BaseHeaderSize.
  rcvrIsBytes
  ifTrue: [[i < end]
  whileTrue: [self byteAt: i put: fillValue.
  i := i + 1]]
  ifFalse: [[i < end]
  whileTrue: [self long32At: i put: fillValue.
  i := i + 4]].
  self pop: 1]!

Item was changed:
  ----- Method: ObjectMemory>>upward (in category 'gc -- mark and sweep') -----
  upward
  "Return from marking an object below. Incoming:
  field = oop we just worked on, needs to be put away
  parentField = where to put it in our object
  NOTE: Type field of object below has already been restored!!!!!! "
  | type header |
  self inline: true.
  (parentField bitAnd: 1) = 1
  ifTrue: [parentField = GCTopMarker
  ifTrue: ["top of the chain"
+ header := (self longAt: field) bitAnd: self allButTypeMask.
- header := (self longAt: field) bitAnd: AllButTypeMask.
  type := self rightType: header.
  self longAt: field put: (header bitOr: type). "install type on class oop"
  ^ Done]
  ifFalse: ["was working on the extended class word"
  child := field. "oop of class"
  field := parentField - 1. "class word, ** clear the low bit **"
  parentField := self longAt: field.
+ header := self longAt: field + self bytesPerWord. "base header word"
- header := self longAt: field + BytesPerWord. "base header word"
  type := self rightType: header.
  self longAt: field put: (child bitOr: type). "install type on class oop"
+ field := field + self bytesPerWord. "point at header"
- field := field + BytesPerWord. "point at header"
  "restore type bits"
+ header := header bitAnd: self allButTypeMask.
- header := header bitAnd: AllButTypeMask.
  self longAt: field put: (header bitOr: type).
  ^ Upward]]
  ifFalse: ["normal"
  child := field. "who we worked on below"
  field := parentField. "where to put it"
  parentField := self longAt: field.
  self longAt: field put: child.
+ field := field - self bytesPerWord. "point at header"
- field := field - BytesPerWord. "point at header"
  ^ StartField]!

Item was changed:
  ----- Method: Interpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') -----
  displayBitsOf: aForm Left: l Top: t Right: r Bottom: b
  "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."
 
  | displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle |
  displayObj := self splObj: TheDisplay.
  aForm = displayObj ifFalse: [^ nil].
  self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
  successFlag ifTrue: [
  dispBits := self fetchPointer: 0 ofObject: displayObj.
  w := self fetchInteger: 1 ofObject: displayObj.
  h := self fetchInteger: 2 ofObject: displayObj.
  d := self fetchInteger: 3 ofObject: displayObj.
  ].
  l < 0 ifTrue:[left := 0] ifFalse: [left := l].
  r > w ifTrue: [right := w] ifFalse: [right := r].
  t < 0 ifTrue: [top := 0] ifFalse: [top := t].
  b > h ifTrue: [bottom := h] ifFalse: [bottom := b].
  ((left <= right) and: [top <= bottom]) ifFalse: [^nil].
  successFlag ifTrue: [
  (self isIntegerObject: dispBits) ifTrue: [
  surfaceHandle := self integerValueOf: dispBits.
  showSurfaceFn = 0 ifTrue: [
  showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'.
  showSurfaceFn = 0 ifTrue: [^self success: false]].
  self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'.
  ] ifFalse: [
+ dispBitsIndex := dispBits + self baseHeaderSize.  "index in memory byte array"
- dispBitsIndex := dispBits + BaseHeaderSize.  "index in memory byte array"
  self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)'
  inSmalltalk: [self showDisplayBits: dispBitsIndex
  w: w h: h d: d
  left: left right: right top: top bottom: bottom]
  ].
  ].!

Item was changed:
  ----- Method: Interpreter>>internalStackValue: (in category 'contexts') -----
  internalStackValue: offset
 
+ ^ self longAtPointer: localSP - (offset * self bytesPerWord)!
- ^ self longAtPointer: localSP - (offset * BytesPerWord)!

Item was changed:
  ----- Method: Interpreter>>lengthOf:baseHeader:format: (in category 'array primitive support') -----
  lengthOf: oop baseHeader: hdr format: fmt
  "Return the number of indexable bytes or words in the given object. Assume the given oop is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result of this method."
 
  | sz |
  self inline: true.
  (hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self longSizeMask ]
+ ifFalse: [ sz := (hdr bitAnd: self sizeMask)].
+ sz := sz - (hdr bitAnd: self size4Bit).
- ifTrue: [ sz := (self sizeHeader: oop) bitAnd: LongSizeMask ]
- ifFalse: [ sz := (hdr bitAnd: SizeMask)].
- sz := sz - (hdr bitAnd: Size4Bit).
  fmt <= 4
+ ifTrue: [ ^ (sz - self baseHeaderSize) >> self shiftForWord "words"].
- ifTrue: [ ^ (sz - BaseHeaderSize) >> ShiftForWord "words"].
  fmt < 8
+ ifTrue: [ ^ (sz - self baseHeaderSize) >> 2 "32-bit longs"]
+ ifFalse: [ ^ (sz - self baseHeaderSize) - (fmt bitAnd: 3) "bytes"]!
- ifTrue: [ ^ (sz - BaseHeaderSize) >> 2 "32-bit longs"]
- ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3) "bytes"]!

Item was changed:
  ----- Method: ObjectMemory>>sufficientSpaceToAllocate: (in category 'allocation') -----
  sufficientSpaceToAllocate: bytes
  "Return true if there is enough space to allocate the given number of bytes,
  perhaps after doing a garbage collection. Sender is responsible for ensuring
  that requested size does result in arithmetic overflow, see note below."
 
  | minFree |
  self inline: true.
  self var: #bytes type: 'usqInt'.
  self var: #minFree type: 'usqInt'.
 
  "Note: Arithmetic overflow may occur in calculation of minFree (indicated by
  minFree < bytes after calculation of minFree). The check is performed by sender
  to avoid redundant test here."
+ minFree := lowSpaceThreshold + bytes + self baseHeaderSize.
- minFree := lowSpaceThreshold + bytes + BaseHeaderSize.
 
  "check for low-space"
  (self oop: (self sizeOfFree: freeBlock) isGreaterThanOrEqualTo: minFree)
  ifTrue: [^true]
  ifFalse: [^self sufficientSpaceAfterGC: minFree].!

Item was changed:
  ----- Method: ObjectMemory>>storePointerUnchecked:ofObject:withValue: (in category 'interpreter access') -----
  storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer
  "Like storePointer:ofObject:withValue:, but the caller guarantees that the object being stored into is a young object or is already marked as a root."
 
+ ^ self longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord)
- ^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)
  put: valuePointer
  !

Item was changed:
  ----- Method: Interpreter>>imageFormatForwardCompatibilityVersion (in category 'image save/restore') -----
  imageFormatForwardCompatibilityVersion
  "This VM is forwards-compatible with the immediately following closure version, and
  will write the new version number in snapshots if the closure creation bytecode is used."
 
+ self bytesPerWord == 4
- BytesPerWord == 4
  ifTrue: [^6504]
  ifFalse: [^68002]!

Item was changed:
  ----- Method: Interpreter>>arrayValueOf: (in category 'utilities') -----
  arrayValueOf: arrayOop
  "Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
  "Note: May be called by translated primitive code."
 
  self returnTypeC: 'void *'.
  ((self isIntegerObject: arrayOop) not and:
  [self isWordsOrBytes: arrayOop])
+ ifTrue: [^ self pointerForOop: (arrayOop + self baseHeaderSize)].
- ifTrue: [^ self pointerForOop: (arrayOop + BaseHeaderSize)].
  self primitiveFail.
  !

Item was changed:
  ----- Method: ObjectMemory>>sizeOfFree: (in category 'header access') -----
  sizeOfFree: oop
  "Return the size of the given chunk in bytes. Argument MUST be a free chunk."
  self returnTypeC: 'usqInt'.
+ ^ (self longAt: oop) bitAnd: self allButTypeMask!
- ^ (self longAt: oop) bitAnd: AllButTypeMask!

Item was changed:
  ----- Method: ObjectMemory>>fetchLong32LengthOf: (in category 'interpreter access') -----
  fetchLong32LengthOf: objectPointer
  "Gives size appropriate for, eg, fetchLong32"
 
  | sz |
  sz := self sizeBitsOf: objectPointer.
+ ^ (sz - self baseHeaderSize) >> 2!
- ^ (sz - BaseHeaderSize) >> 2!

Item was changed:
  ----- Method: Interpreter>>reverseBytesFrom:to: (in category 'image save/restore') -----
  reverseBytesFrom: startAddr to: stopAddr
  "Byte-swap the given range of memory (not inclusive of stopAddr!!)."
  | addr |
  self flag: #Dan.
  addr := startAddr.
  [self oop: addr isLessThan: stopAddr] whileTrue:
  [self longAt: addr put: (self byteSwapped: (self longAt: addr)).
+ addr := addr + self bytesPerWord].!
- addr := addr + BytesPerWord].!

Item was changed:
  ----- Method: Interpreter>>reverseDisplayFrom:to: (in category 'I/O primitive support') -----
  reverseDisplayFrom: startIndex to: endIndex
  "Reverse the given range of Display words (at different bit
  depths, this will reverse different numbers of pixels). Used to
  give feedback during VM activities such as garbage
  collection when debugging. It is assumed that the given
  word range falls entirely within the first line of the Display."
  | displayObj dispBitsPtr w reversed |
  displayObj := self splObj: TheDisplay.
  ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
  w := self fetchInteger: 1 ofObject: displayObj.
  dispBitsPtr := self fetchPointer: 0 ofObject: displayObj.
  (self isIntegerObject: dispBitsPtr) ifTrue: [^ nil].
+ dispBitsPtr := dispBitsPtr + self baseHeaderSize.
- dispBitsPtr := dispBitsPtr + BaseHeaderSize.
  dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4
  do: [:ptr |
  reversed := (self long32At: ptr) bitXor: 4294967295.
  self longAt: ptr put: reversed].
  successFlag := true.
  self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1.
  self ioForceDisplayUpdate!

Item was changed:
  ----- Method: ObjectMemory>>allocateOrRecycleContext: (in category 'allocation') -----
  allocateOrRecycleContext: needsLarge
  "Return a recycled context or a newly allocated one if none is available for recycling."
  | cntxt |
  needsLarge = 0
  ifTrue: [freeContexts ~= NilContext ifTrue:
  [cntxt := freeContexts.
  freeContexts := self fetchPointer: 0 ofObject: cntxt.
  ^ cntxt]]
  ifFalse: [freeLargeContexts ~= NilContext ifTrue:
  [cntxt := freeLargeContexts.
  freeLargeContexts := self fetchPointer: 0 ofObject: cntxt.
  ^ cntxt]].
 
  needsLarge = 0
  ifTrue: [cntxt := self instantiateContext: (self splObj: ClassMethodContext)
+ sizeInBytes: self smallContextSize]
- sizeInBytes: SmallContextSize]
  ifFalse: [cntxt := self instantiateContext: (self splObj: ClassMethodContext)
+ sizeInBytes: self largeContextSize].
- sizeInBytes: LargeContextSize].
  "Required init -- above does not fill w/nil.  All others get written."
  self storePointerUnchecked: 4 "InitialIPIndex" ofObject: cntxt
  withValue: nilObj.
  ^ cntxt
  !

Item was changed:
  ----- Method: ObjectMemory>>lastPointerWhileForwarding: (in category 'gc -- compaction') -----
  lastPointerWhileForwarding: oop
  "The given object may have its header word in a forwarding block. Find  
  the offset of the last pointer in the object in spite of this obstacle. "
  | header fwdBlock fmt size methodHeader contextSize |
  self inline: true.
  header := self longAt: oop.
+ (header bitAnd: self markBit) ~= 0
- (header bitAnd: MarkBit) ~= 0
  ifTrue: ["oop is forwarded; get its real header from its forwarding table entry"
+ fwdBlock := (header bitAnd: self allButMarkBitAndTypeMask) << 1.
- fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
  DoAssertionChecks
  ifTrue: [self fwdBlockValidate: fwdBlock].
+ header := self longAt: fwdBlock + self bytesPerWord].
- header := self longAt: fwdBlock + BytesPerWord].
  fmt := header >> 8 bitAnd: 15.
  fmt <= 4
  ifTrue: [(fmt = 3 and: [self isContextHeader: header])
  ifTrue: ["contexts end at the stack pointer"
  contextSize := self fetchStackPointerOf: oop.
+ ^ CtxtTempFrameStart + contextSize * self bytesPerWord].
- ^ CtxtTempFrameStart + contextSize * BytesPerWord].
  "do sizeBitsOf: using the header we obtained"
  (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [size := (self sizeHeader: oop) bitAnd: self allButTypeMask]
+ ifFalse: [size := header bitAnd: self sizeMask].
+ ^ size - self baseHeaderSize].
- ifTrue: [size := (self sizeHeader: oop) bitAnd: AllButTypeMask]
- ifFalse: [size := header bitAnd: SizeMask].
- ^ size - BaseHeaderSize].
  fmt < 12 ifTrue: [^ 0]. "no pointers"
+ methodHeader := self longAt: oop + self baseHeaderSize.
+ ^ (methodHeader >> 10 bitAnd: 255) * self bytesPerWord + self baseHeaderSize!
- methodHeader := self longAt: oop + BaseHeaderSize.
- ^ (methodHeader >> 10 bitAnd: 255) * BytesPerWord + BaseHeaderSize!

Item was changed:
  ----- Method: ObjectMemory>>allYoung:and: (in category 'become') -----
  allYoung: array1 and: array2
  "Return true if all the oops in both arrays, and the arrays
  themselves, are in the young object space."
  | fieldOffset |
  (self oop: array1 isLessThan: youngStart)
  ifTrue: [^ false].
  (self oop: array2 isLessThan: youngStart)
  ifTrue: [^ false].
  fieldOffset := self lastPointerOf: array1.
  "same size as array2"
+ [fieldOffset >= self baseHeaderSize] whileTrue:
- [fieldOffset >= BaseHeaderSize] whileTrue:
  [(self oop: (self longAt: array1 + fieldOffset) isLessThan: youngStart)
  ifTrue: [^ false].
  (self oop: (self longAt: array2 + fieldOffset) isLessThan: youngStart)
  ifTrue: [^ false].
+ fieldOffset := fieldOffset - self bytesPerWord].
- fieldOffset := fieldOffset - BytesPerWord].
  ^ true!

Item was changed:
  ----- Method: ObjectMemory>>initForwardBlock:mapping:to:withBackPtr: (in category 'gc -- compaction') -----
  initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: backFlag
  "Initialize the given forwarding block to map oop to newOop,
  and replace oop's header with a pointer to the fowarding
  block. "
  "Details: The mark bit is used to indicate that an oop is
  forwarded. When an oop is forwarded, its header (minus the
  mark bit) contains the address of its forwarding block. (The
  forwarding block address is actually shifted right by one bit
  so that its top-most bit does not conflict with the header's
  mark bit; since fowarding blocks are stored on word
  boundaries, the low two bits of the address are always zero.)
  The first word of the forwarding block is the new oop; the
  second word is the oop's orginal header. In the case of a
  forward become, a four-word block is used, with the third
  field being a backpointer to the old oop (for header fixup),
  and the fourth word is unused. The type bits of the
  forwarding header are the same as those of the original
  header. "
  | originalHeader originalHeaderType |
  self inline: true.
  originalHeader := self longAt: oop.
  DoAssertionChecks
  ifTrue: [fwdBlock = nil ifTrue: [self error: 'ran out of forwarding blocks in become'].
+ (originalHeader bitAnd: self markBit) ~= 0
- (originalHeader bitAnd: MarkBit) ~= 0
  ifTrue: [self error: 'object already has a forwarding table entry']].
  originalHeaderType := originalHeader bitAnd: TypeMask.
  self longAt: fwdBlock put: newOop.
+ self longAt: fwdBlock + self bytesPerWord put: originalHeader.
+ backFlag ifTrue: [self longAt: fwdBlock + (self bytesPerWord * 2) put: oop].
+ self longAt: oop put: (fwdBlock >> 1 bitOr: (self markBit bitOr: originalHeaderType))!
- self longAt: fwdBlock + BytesPerWord put: originalHeader.
- backFlag ifTrue: [self longAt: fwdBlock + (BytesPerWord*2) put: oop].
- self longAt: oop put: (fwdBlock >> 1 bitOr: (MarkBit bitOr: originalHeaderType))!

Item was added:
+ ----- Method: ObjectMemory>>allButTypeMask (in category 'constants') -----
+ allButTypeMask
+ "Mask for type field"
+
+ self inline: true.
+ ^self
+ cCode: 'ALL_BUT_TYPE_MASK'
+ inSmalltalk: [self wordMask - TypeMask]
+ !

Item was changed:
  ----- Method: ObjectMemory>>beRootWhileForwarding: (in category 'gc -- compaction') -----
  beRootWhileForwarding: oop
  "Record that the given oop in the old object area points to an object in the young area when oop may be forwarded."
  "Warning: No young objects should be recorded as roots. Callers are responsible for ensuring this constraint is not violated."
 
  | header fwdBlock |
  header := self longAt: oop.
+ (header bitAnd: self markBit) ~= 0
- (header bitAnd: MarkBit) ~= 0
  ifTrue: ["This oop is forwarded"
+ fwdBlock := (header bitAnd: self allButMarkBitAndTypeMask) << 1.
- fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
  DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
+ self noteAsRoot: oop headerLoc: fwdBlock + self bytesPerWord]
- self noteAsRoot: oop headerLoc: fwdBlock + BytesPerWord]
  ifFalse: ["Normal -- no forwarding"
  self noteAsRoot: oop headerLoc: oop]!

Item was changed:
  ----- Method: ObjectMemory>>storeByte:ofObject:withValue: (in category 'interpreter access') -----
  storeByte: byteIndex ofObject: oop withValue: valueByte
 
+ ^ self byteAt: oop + self baseHeaderSize + byteIndex
- ^ self byteAt: oop + BaseHeaderSize + byteIndex
  put: valueByte!

Item was added:
+ ----- Method: ObjectMemory>>allButHashBits (in category 'constants') -----
+ allButHashBits
+ "Base header word bit fields"
+
+ self inline: true.
+ ^self
+ cCode: 'ALL_BUT_HASH_BITS'
+ inSmalltalk: [self wordMask - HashBits]
+ !

Item was changed:
  ----- Method: CCodeGenerator>>emitDefineBytesPerWord:on: (in category 'C code generator') -----
  emitDefineBytesPerWord: bytesPerWord on: aStream
+ "Define word size dependent constants. These are mirrored by class
+ variables in ObjectMemory. The macro definitions here are used at compile
+ time to permit building a VM for either 32-bit or 64-bit object memory from
+ a single generated code base.
+
+ If SQ_VI_BYTES_PER_WORD is defined as 8 (e.g. in config.h), then a VM for
+ 64-bit image will be built. Otherwise, a VM for 32-bit image is built."
+
+ aStream cr;
+ nextPutAll: '/*'; cr;
+ nextPutAll: ' * define SQ_VI_BYTES_PER_WORD 8 for a 64-bit word size VM'; cr;
+ nextPutAll: ' * and default to SQ_VI_BYTES_PER_WORD 4 for a 32-bit word size VM'; cr;
+ nextPutAll: ' */'; cr;
+ nextPutAll: '#ifndef SQ_VI_BYTES_PER_WORD'; cr;
+ nextPutAll: '# define SQ_VI_BYTES_PER_WORD ';
+ print: bytesPerWord; cr;
+ nextPutAll: '#endif'; cr; cr;
+ nextPutAll: '#define BYTES_PER_WORD SQ_VI_BYTES_PER_WORD'; cr;
+ nextPutAll: '#define BASE_HEADER_SIZE SQ_VI_BYTES_PER_WORD'; cr;
+
+ "Define various constants that depend on BytesPerWord"
+ nextPutAll: '#if (BYTES_PER_WORD == 4) // 32-bit object memory'; cr;
+ nextPutAll: '# define WORD_MASK 0xffffffff'; cr; "(1 bitShift: BytesPerWord*8) - 1"
+ nextPutAll: '# define SHIFT_FOR_WORD 2'; cr; "(BytesPerWord log: 2) rounded"
+ nextPutAll: '# define SMALL_CONTEXT_SIZE 92'; cr; "ContextFixedSizePlusHeader + 16 * BytesPerWord"
+ "Large contexts have 56 indexable fileds.  Max with single header word."
+ "However note that in 64 bits, for now, large contexts have 3-word headers"
+ nextPutAll: '# define LARGE_CONTEXT_SIZE 252'; cr; "ContextFixedSizePlusHeader + 56 * BytesPerWord."
+ nextPutAll: '# define SIZE_MASK 0xfc'; cr; "Base header word bit field"
+ nextPutAll: '# define LONG_SIZE_MASK 0xfffffffc'; cr; "Base header word bit field"
+ nextPutAll: '# define SIZE_4_BIT 0'; cr;
+ nextPutAll: '# define MARK_BIT 0x80000000'; cr; "Top bit, 1 bitShift: BytesPerWord*8 - 1"
+ nextPutAll: '# define ROOT_BIT 0x40000000'; cr; "Next-to-top bit, 1 bitShift: BytesPerWord*8 - 2"
+ nextPutAll: '# define ALL_BUT_MARK_BIT 0x7fffffff'; cr; "WordMask - MarkBit."
+ nextPutAll: '# define ALL_BUT_ROOT_BIT 0xbfffffff'; cr; "WordMask - RootBit"
+ nextPutAll: '# define ALL_BUT_TYPE_MASK 0xfffffffc'; cr; "WordMask - TypeMask"
+ nextPutAll: '# define ALL_BUT_MARK_BIT_AND_TYPE_MASK 0x7ffffffc'; cr; "AllButTypeMask - MarkBit"
+ nextPutAll: '# define ALL_BUT_HASH_BITS 0xe001ffff'; cr;
+
+ nextPutAll: '#else // 64-bit object memory'; cr;
+ nextPutAll: '# define WORD_MASK 0xffffffffffffffff'; cr;
+ nextPutAll: '# define SHIFT_FOR_WORD 3'; cr;
+ nextPutAll: '# define SMALL_CONTEXT_SIZE 184'; cr;
+ nextPutAll: '# define LARGE_CONTEXT_SIZE 504'; cr;
+ nextPutAll: '# define SIZE_MASK 0xf8'; cr; "Lose the 4 bit in temp 64-bit chunk format"
+ nextPutAll: '# define LONG_SIZE_MASK 0xfffffffffffffff8'; cr;
+ "The 4 bit is excluded from SIZE_MASK for 64-bit object memory, but need it"
+ "for ST size, so define SIZE_4_BIT."
+ nextPutAll: '# define SIZE_4_BIT 4'; cr;
+ nextPutAll: '# define MARK_BIT 0x8000000000000000'; cr;
+ nextPutAll: '# define ROOT_BIT 0x4000000000000000'; cr;
+ nextPutAll: '# define ALL_BUT_MARK_BIT 0x7fffffffffffffff'; cr;
+ nextPutAll: '# define ALL_BUT_ROOT_BIT 0xbfffffffffffffff'; cr;
+ nextPutAll: '# define ALL_BUT_TYPE_MASK 0xfffffffffffffffc'; cr;
+ nextPutAll: '# define ALL_BUT_MARK_BIT_AND_TYPE_MASK 0x7ffffffffffffffc'; cr;
+ nextPutAll: '# define ALL_BUT_HASH_BITS 0xffffffffe001ffff'; cr;
+ nextPutAll: '#endif //  (BYTES_PER_WORD == 4)'; cr
+
+ !
- aStream
- nextPutAll: '#define SQ_VI_BYTES_PER_WORD ';
- print: bytesPerWord;
- cr!

Item was changed:
  ----- Method: ObjectMemory>>fetchClassOf: (in category 'interpreter access') -----
  fetchClassOf: oop
  | ccIndex |
  self inline: true.
  (self isIntegerObject: oop) ifTrue: [^ self splObj: ClassInteger].
 
  ccIndex := (self baseHeader: oop) >> 12 bitAnd: 31.
  ccIndex = 0
  ifTrue: [^ (self classHeader: oop)
+ bitAnd: self allButTypeMask]
- bitAnd: AllButTypeMask]
  ifFalse: ["look up compact class"
  ^ self fetchPointer: ccIndex - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)]!

Item was changed:
  ----- Method: ObjectMemory>>markAndTrace: (in category 'gc -- mark and sweep') -----
  markAndTrace: oop
  "Mark all objects reachable from the given one.
  Trace from the given object even if it is old.
  Do not trace if it is already marked.
  Mark it only if it is a young object."
  "Tracer state variables:
  child object being examined
  field next field of child to examine
  parentField field where child was stored in its referencing object"
 
  | header lastFieldOffset action statMarkCountLocal |
  header := self longAt: oop.
+ (header bitAnd: self markBit) = 0 ifFalse: [^ 0  "already marked"].
- (header bitAnd: MarkBit) = 0 ifFalse: [^ 0  "already marked"].
 
  "record tracing status in object's header"
+ header := (header bitAnd: self allButTypeMask) bitOr: HeaderTypeGC.
- header := (header bitAnd: AllButTypeMask) bitOr: HeaderTypeGC.
  (self oop: oop isGreaterThanOrEqualTo: youngStart)
+ ifTrue: [ header := header bitOr: self markBit ].  "mark only if young"
- ifTrue: [ header := header bitOr: MarkBit ].  "mark only if young"
  self longAt: oop put: header.
 
  "initialize the tracer state machine"
  parentField := GCTopMarker.
  child := oop.
  (self isWeakNonInt: oop) ifTrue: [
  "Set lastFieldOffset before the weak fields in the receiver"
+ lastFieldOffset := (self nonWeakFieldsOf: oop) << self shiftForWord.
- lastFieldOffset := (self nonWeakFieldsOf: oop) << ShiftForWord.
  "And remember as weak root"
  weakRootCount := weakRootCount + 1.
  weakRoots at: weakRootCount put: oop.
  ] ifFalse: [
  "Do it the usual way"
  lastFieldOffset := self lastPointerOf: oop.
  ].
  field := oop + lastFieldOffset.
  action := StartField.
  youngStartLocal := youngStart.
  statMarkCountLocal := statMarkCount.
  "run the tracer state machine until all objects reachable from oop are marked"
  [action = Done] whileFalse: [
  statMarkCountLocal := statMarkCountLocal + 1.
  action = StartField ifTrue: [ action := self startField ].
  action = StartObj ifTrue: [ action := self startObj ].
  action = Upward ifTrue: [ action := self upward ].
  ].
  statMarkCount := statMarkCountLocal.!

Item was changed:
  ----- Method: Interpreter>>pop:thenPushInteger: (in category 'contexts') -----
  pop: nItems thenPushInteger: integerVal
  "lots of places pop a few items off the stack and then push an integer. MAke it convenient"
  | sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * self bytesPerWord)) put:(self integerObjectOf: integerVal).
- self longAt: (sp := stackPointer - ((nItems - 1) * BytesPerWord)) put:(self integerObjectOf: integerVal).
  stackPointer := sp.
  !

Item was changed:
  ----- Method: Interpreter>>popFloat (in category 'stack bytecodes') -----
  popFloat
  "Note: May be called by translated primitive code."
 
  | top result |
  self returnTypeC: 'double'.
  self var: #result type: 'double '.
  top := self popStack.
  self assertClassOf: top is: (self splObj: ClassFloat).
  successFlag ifTrue:
  [self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: top + self baseHeaderSize into: result].
- self fetchFloatAt: top + BaseHeaderSize into: result].
  ^ result!

Item was changed:
  ----- Method: Interpreter>>internalPush: (in category 'contexts') -----
  internalPush: object
 
+ self longAtPointer: (localSP := localSP + self bytesPerWord) put: object.!
- self longAtPointer: (localSP := localSP + BytesPerWord) put: object.!

Item was changed:
  ----- Method: ObjectMemory>>sweepPhase (in category 'gc -- mark and sweep') -----
  sweepPhase
  "Sweep memory from youngStart through the end of memory. Free all
  inaccessible objects and coalesce adjacent free chunks. Clear the mark
  bits of accessible objects. Compute the starting point for the first pass of
  incremental compaction (compStart). Return the number of surviving
  objects. "
  "Details: Each time a non-free object is encountered, decrement the
  number of available forward table entries. If all entries are spoken for
  (i.e., entriesAvailable reaches zero), set compStart to the last free
  chunk before that object or, if there is no free chunk before the given
  object, the first free chunk after it. Thus, at the end of the sweep
  phase, compStart through compEnd spans the highest collection of
  non-free objects that can be accomodated by the forwarding table. This
  information is used by the first pass of incremental compaction to
  ensure that space is initially freed at the end of memory. Note that
  there should always be at least one free chunk--the one at the end of
  the heap."
  | entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize endOfMemoryLocal |
  self inline: false.
  self var: #oop type: 'usqInt'.
  self var: #endOfMemoryLocal type: 'usqInt'.
+ entriesAvailable := self fwdTableInit: self bytesPerWord * 2.
- entriesAvailable := self fwdTableInit: BytesPerWord*2.
  survivors := 0.
  freeChunk := nil.
  firstFree := nil.
  "will be updated later"
  endOfMemoryLocal := endOfMemory.
  oop := self oopFromChunk: youngStart.
  [oop < endOfMemoryLocal]
  whileTrue: ["get oop's header, header type, size, and header size"
  statSweepCount := statSweepCount + 1.
  oopHeader := self baseHeader: oop.
  oopHeaderType := oopHeader bitAnd: TypeMask.
  hdrBytes := headerTypeBytes at: oopHeaderType.
  (oopHeaderType bitAnd: 1) = 1
+ ifTrue: [oopSize := oopHeader bitAnd: self sizeMask]
- ifTrue: [oopSize := oopHeader bitAnd: SizeMask]
  ifFalse: [oopHeaderType = HeaderTypeSizeAndClass
+ ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: self longSizeMask]
+ ifFalse: ["free chunk" oopSize := oopHeader bitAnd: self longSizeMask]].
+ (oopHeader bitAnd: self markBit) = 0
- ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: LongSizeMask]
- ifFalse: ["free chunk" oopSize := oopHeader bitAnd: LongSizeMask]].
- (oopHeader bitAnd: MarkBit) = 0
  ifTrue: ["object is not marked; free it"
  "<-- Finalization support: We need to mark each oop chunk as free -->"
  self longAt: oop - hdrBytes put: HeaderTypeFree.
  freeChunk ~= nil
  ifTrue: ["enlarge current free chunk to include this oop"
  freeChunkSize := freeChunkSize + oopSize + hdrBytes]
  ifFalse: ["start a new free chunk"
  freeChunk := oop - hdrBytes.
  "chunk may start 4 or 8 bytes before oop"
  freeChunkSize := oopSize + (oop - freeChunk).
  "adjust size for possible extra header bytes"
  firstFree = nil ifTrue: [firstFree := freeChunk]]]
  ifFalse: ["object is marked; clear its mark bit and possibly adjust
  the compaction start"
+ self longAt: oop put: (oopHeader bitAnd: self allButMarkBit).
- self longAt: oop put: (oopHeader bitAnd: AllButMarkBit).
  "<-- Finalization support: Check if we're running about a weak class -->"
  (self isWeakNonInt: oop) ifTrue: [self finalizeReference: oop].
  entriesAvailable > 0
  ifTrue: [entriesAvailable := entriesAvailable - 1]
  ifFalse: ["start compaction at the last free chunk before this object"
  firstFree := freeChunk].
  freeChunk ~= nil
  ifTrue: ["record the size of the last free chunk"
+ self longAt: freeChunk put: ((freeChunkSize bitAnd: self longSizeMask) bitOr: HeaderTypeFree).
- self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree).
  freeChunk := nil].
  survivors := survivors + 1].
  oop := self oopFromChunk: oop + oopSize].
  freeChunk ~= nil
  ifTrue: ["record size of final free chunk"
+ self longAt: freeChunk put: ((freeChunkSize bitAnd: self longSizeMask) bitOr: HeaderTypeFree)].
- self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree)].
  oop = endOfMemory
  ifFalse: [self error: 'sweep failed to find exact end of memory'].
  firstFree = nil
  ifTrue: [self error: 'expected to find at least one free object']
  ifFalse: [compStart := firstFree].
 
  ^ survivors!

Item was changed:
  ----- Method: ObjectMemory>>restoreHeadersAfterForwardBecome: (in category 'become') -----
  restoreHeadersAfterForwardBecome: copyHashFlag
  "Forward become leaves us with no original oops in the
  mutated object list,
  so we must enumerate the (four-word) forwarding blocks
  where we have stored backpointers."
  "This loop start is copied from fwdTableInit:"
  | oop1 fwdBlock oop2 hdr1 hdr2 |
+ fwdBlock := endOfMemory + self baseHeaderSize + 7 bitAnd: self wordMask - 7.
- fwdBlock := endOfMemory + BaseHeaderSize + 7 bitAnd: WordMask - 7.
  self flag: #Dan.  "See flag comment in fwdTableInit: (dtl)"
+ fwdBlock := fwdBlock + (self bytesPerWord * 4).
- fwdBlock := fwdBlock + (BytesPerWord*4).
  "fwdBlockGet: did a pre-increment"
  [self oop: fwdBlock isLessThanOrEqualTo: fwdTableNext
  "fwdTableNext points to the last active block"]
+ whileTrue: [oop1 := self longAt: fwdBlock + (self bytesPerWord * 2).
- whileTrue: [oop1 := self longAt: fwdBlock + (BytesPerWord*2).
  "Backpointer to mutated object."
  oop2 := self longAt: fwdBlock.
  self restoreHeaderOf: oop1.
  copyHashFlag
  ifTrue: ["Change the hash of the new oop (oop2) to be that of the old (oop1)
  so mutated objects in hash structures will be
  happy after the change."
  hdr1 := self longAt: oop1.
  hdr2 := self longAt: oop2.
+ self longAt: oop2 put: ((hdr2 bitAnd: self allButHashBits) bitOr: (hdr1 bitAnd: HashBits))].
+ fwdBlock := fwdBlock + (self bytesPerWord * 4)]!
- self longAt: oop2 put: ((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits))].
- fwdBlock := fwdBlock + (BytesPerWord*4)]!

Item was added:
+ ----- Method: ObjectMemory>>allButRootBit (in category 'constants') -----
+ allButRootBit
+ "Mask for root bit"
+
+ self inline: true.
+ ^self
+ cCode: 'ALL_BUT_ROOT_BIT'
+ inSmalltalk: [self wordMask - self rootBit]
+ !

Item was changed:
  ----- Method: Interpreter>>firstFixedField: (in category 'plugin support') -----
  firstFixedField: oop
 
  self returnTypeC: 'char *'.
+ ^ self pointerForOop: oop + self baseHeaderSize!
- ^ self pointerForOop: oop + BaseHeaderSize!

Item was added:
+ ----- Method: ArrayedCollection>>coerceTo:sim: (in category '*VMMaker-simulated image growing') -----
+ coerceTo: cTypeString sim: interpreterSimulator
+
+ ^ self!

Item was changed:
  ----- Method: Interpreter>>primitiveExecuteMethodArgsArray (in category 'control primitives') -----
  primitiveExecuteMethodArgsArray
  "receiver, argsArray, then method are on top of stack.  Execute method against receiver and args"
 
  | methodArgument argCnt argumentArray |
  methodArgument := self popStack.
  argumentArray := self popStack.
  ((self isNonIntegerObject: methodArgument)
  and: [(self isCompiledMethod: newMethod)
  and: [self isArray: argumentArray]]) ifFalse:
  [self unPop: 2. ^self primitiveFail].
  argCnt := self argumentCountOf: methodArgument.
  argCnt = (self fetchWordLengthOf: argumentArray) ifFalse:
  [self unPop: 2. ^self primitiveFail].
+ self transfer: argCnt from: argumentArray + self baseHeaderSize to: stackPointer + self bytesPerWord.
- self transfer: argCnt from: argumentArray + BaseHeaderSize to: stackPointer + BytesPerWord.
  self unPop: argCnt.
  newMethod := methodArgument.
  primitiveIndex := self primitiveIndexOf: newMethod.
  argumentCount := argCnt.
  self executeNewMethod.
  "Recursive xeq affects successFlag"
  successFlag := true!

Item was changed:
  ----- Method: ObjectMemory>>setSizeOfFree:to: (in category 'header access') -----
  setSizeOfFree: chunk to: byteSize
  "Set the header of the given chunk to make it be a free chunk of the given size."
 
+ self longAt: chunk put: ((byteSize bitAnd: self allButTypeMask) bitOr: HeaderTypeFree).!
- self longAt: chunk put: ((byteSize bitAnd: AllButTypeMask) bitOr: HeaderTypeFree).!

Item was changed:
  ----- Method: ObjectMemory>>isObjectForwarded: (in category 'gc -- compaction') -----
  isObjectForwarded: oop
  "Return true if the given object has a forwarding table entry
  during a compaction or become operation."
+ ^ (oop bitAnd: 1) = 0 and: ["(isIntegerObject: oop) not" ((self longAt: oop) bitAnd: self markBit) ~= 0]!
- ^ (oop bitAnd: 1) = 0 and: ["(isIntegerObject: oop) not" ((self longAt: oop) bitAnd: MarkBit) ~= 0]!

Item was changed:
  ----- Method: Interpreter>>stackPointerIndex (in category 'contexts') -----
  stackPointerIndex
  "Return the 0-based index rel to the current context.
  (This is what stackPointer used to be before conversion to pointer"
+ ^ (stackPointer - activeContext - self baseHeaderSize) >> self shiftForWord!
- ^ (stackPointer - activeContext - BaseHeaderSize) >> ShiftForWord!

Item was changed:
  ----- Method: Interpreter>>sizeOfSTArrayFromCPrimitive: (in category 'utilities') -----
  sizeOfSTArrayFromCPrimitive: cPtr
  "Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that."
  "Note: Only called by translated primitive code."
 
  | oop |
  self var: #cPtr type: 'void *'.
+ oop := (self oopForPointer: (self cCoerce: cPtr to: 'char *')) - self baseHeaderSize.
- oop := (self oopForPointer: (self cCoerce: cPtr to: 'char *')) - BaseHeaderSize.
  (self isWordsOrBytes: oop) ifFalse: [
  self primitiveFail.
  ^0].
  ^self lengthOf: oop
  !

Item was changed:
  ----- Method: Interpreter>>createActualMessageTo: (in category 'message sending') -----
  createActualMessageTo: aClass
  "Bundle up the selector, arguments and lookupClass into a Message object.
  In the process it pops the arguments off the stack, and pushes the message object.
  This can then be presented as the argument of e.g. #doesNotUnderstand:.
  ikp 11/20/1999 03:59 -- added hook for external runtime compilers."
  "remap lookupClass in case GC happens during allocation"
  | argumentArray message lookupClass |
  self pushRemappableOop: aClass.
  argumentArray := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
  "remap argumentArray in case GC happens during allocation"
  self pushRemappableOop: argumentArray.
  message := self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
  argumentArray := self popRemappableOop.
  lookupClass := self popRemappableOop.
  self beRootIfOld: argumentArray.
 
  compilerInitialized
  ifTrue: [self compilerCreateActualMessage: message storingArgs: argumentArray]
+ ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * self bytesPerWord) to: argumentArray + self baseHeaderSize.
- ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * BytesPerWord) to: argumentArray + BaseHeaderSize.
  self pop: argumentCount thenPush: message].
 
  argumentCount := 1.
  self storePointer: MessageSelectorIndex ofObject: message withValue: messageSelector.
  self storePointer: MessageArgumentsIndex ofObject: message withValue: argumentArray.
+ (self lastPointerOf: message) >= (MessageLookupClassIndex * self bytesPerWord + self baseHeaderSize)
- (self lastPointerOf: message) >= (MessageLookupClassIndex * BytesPerWord + BaseHeaderSize)
  ifTrue: ["Only store lookupClass if message has 3 fields (old images don't)"
  self storePointer: MessageLookupClassIndex ofObject: message withValue: lookupClass]!

Item was added:
+ ----- Method: ObjectMemory>>wordMask (in category 'constants') -----
+ wordMask
+ "Answer a bit mask for an object word, either 32 or 64 bits."
+
+ self inline: true.
+ ^self
+ cCode: 'WORD_MASK'
+ inSmalltalk: [(1 bitShift: self bytesPerWord * 8) - 1]
+ !

Item was changed:
  ----- Method: Interpreter>>internalStoreContextRegisters: (in category 'contexts') -----
  internalStoreContextRegisters: activeCntx
  "The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP."
 
  "InstructionPointer is a pointer variable equal to
+ method oop + ip + self baseHeaderSize
- method oop + ip + BaseHeaderSize
  -1 for 0-based addressing of fetchByte
  -1 because it gets incremented BEFORE fetching currentByte"
 
  self inline: true.
  self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
  withValue: (self integerObjectOf:
+ ((self oopForPointer: localIP) + 2 - (method + self baseHeaderSize))).
- ((self oopForPointer: localIP) + 2 - (method + BaseHeaderSize))).
  self storePointerUnchecked: StackPointerIndex  ofObject: activeCntx
  withValue: (self integerObjectOf:
+ ((((self oopForPointer: localSP) - (activeCntx + self baseHeaderSize)) >> self shiftForWord) - TempFrameStart + 1)).
- ((((self oopForPointer: localSP) - (activeCntx + BaseHeaderSize)) >> ShiftForWord) - TempFrameStart + 1)).
  !

Item was changed:
  ----- Method: ObjectMemory>>restoreHeadersAfterBecoming:with: (in category 'become') -----
  restoreHeadersAfterBecoming: list1 with: list2
  "Restore the headers of all oops in both lists. Exchange their hash bits so
  becoming objects in identity sets and dictionaries doesn't change their
  hash value."
  "See also prepareForwardingTableForBecoming:with:woWay: for notes
  regarding the case
  of oop1 = oop2"
  | fieldOffset oop1 oop2 hdr1 hdr2 |
  fieldOffset := self lastPointerOf: list1.
+ [fieldOffset >= self baseHeaderSize]
- [fieldOffset >= BaseHeaderSize]
  whileTrue: [oop1 := self longAt: list1 + fieldOffset.
  oop2 := self longAt: list2 + fieldOffset.
  oop1 = oop2
  ifFalse: [self restoreHeaderOf: oop1.
  self restoreHeaderOf: oop2.
  "Exchange hash bits of the two objects."
  hdr1 := self longAt: oop1.
  hdr2 := self longAt: oop2.
  self
  longAt: oop1
+ put: ((hdr1 bitAnd: self allButHashBits) bitOr: (hdr2 bitAnd: HashBits)).
- put: ((hdr1 bitAnd: AllButHashBits) bitOr: (hdr2 bitAnd: HashBits)).
  self
  longAt: oop2
+ put: ((hdr2 bitAnd: self allButHashBits) bitOr: (hdr1 bitAnd: HashBits))].
+ fieldOffset := fieldOffset - self bytesPerWord]!
- put: ((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits))].
- fieldOffset := fieldOffset - BytesPerWord]!

Item was changed:
  ----- Method: Interpreter>>stackObjectValue: (in category 'contexts') -----
  stackObjectValue: offset
  "Ensures that the given object is a real object, not a SmallInteger."
 
  | oop |
+ oop := self longAt: stackPointer - (offset * self bytesPerWord).
- oop := self longAt: stackPointer - (offset * BytesPerWord).
  (self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
  ^ oop
  !

Item was changed:
  ----- Method: Interpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
  readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
  "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
  "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
  "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
 
  | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize |
  self var: #f type: 'sqImageFile '.
  self var: #desiredHeapSize type: 'usqInt'.
  self var: #headerStart type: 'squeakFileOffsetType '.
  self var: #dataSize type: 'size_t '.
  self var: #imageOffset type: 'squeakFileOffsetType '.
 
  swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
+ headerStart := (self sqImageFilePosition: f) - self bytesPerWord.  "record header start position"
- headerStart := (self sqImageFilePosition: f) - BytesPerWord.  "record header start position"
 
  headerSize := self getLongFromFile: f swap: swapBytes.
  dataSize := self getLongFromFile: f swap: swapBytes.
  oldBaseAddr := self getLongFromFile: f swap: swapBytes.
  specialObjectsOop := self getLongFromFile: f swap: swapBytes.
  lastHash := self getLongFromFile: f swap: swapBytes.
  savedWindowSize := self getLongFromFile: f swap: swapBytes.
  fullScreenFlag := self getLongFromFile: f swap: swapBytes.
  extraVMMemory := self getLongFromFile: f swap: swapBytes.
 
  lastHash = 0 ifTrue: [
  "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"
  lastHash := 999].
 
  "decrease Squeak object heap to leave extra memory for the VM"
  heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
 
  "compare memory requirements with availability".
  minimumMemory := dataSize + 100000.  "need at least 100K of breathing room"
  heapSize < minimumMemory ifTrue: [
  self insufficientMemorySpecifiedError].
 
  "allocate a contiguous block of memory for the Squeak heap"
  memory := self
  allocateMemory: heapSize
  minimum: minimumMemory
  imageFile: f
  headerSize: headerSize.
  memory = nil ifTrue: [self insufficientMemoryAvailableError].
 
  memStart := self startOfMemory.
  memoryLimit := (memStart + heapSize) - 24.  "decrease memoryLimit a tad for safety"
  endOfMemory := memStart + dataSize.
 
  "position file after the header"
  self sqImageFile: f Seek: headerStart + headerSize.
 
  "read in the image in bulk, then swap the bytes if necessary"
  bytesRead := self
  sqImage: (self pointerForOop: memory)
  read: f
  size: (self cCode: 'sizeof(unsigned char)')
  length: dataSize.
  bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
 
+ headerTypeBytes at: 0 put: self bytesPerWord * 2. "3-word header (type 0)"
+ headerTypeBytes at: 1 put: self bytesPerWord. "2-word header (type 1)"
- headerTypeBytes at: 0 put: BytesPerWord * 2. "3-word header (type 0)"
- headerTypeBytes at: 1 put: BytesPerWord. "2-word header (type 1)"
  headerTypeBytes at: 2 put: 0. "free chunk (type 2)"
  headerTypeBytes at: 3 put: 0. "1-word header (type 3)"
 
  swapBytes ifTrue: [self reverseBytesInImage].
 
  "compute difference between old and new memory base addresses"
  bytesToShift := memStart - oldBaseAddr.
  self initializeInterpreter: bytesToShift.  "adjusts all oops to new location"
  self isBigEnder. "work out the machine endianness and cache the answer"
 
  ^ dataSize
  !

Item was changed:
  ----- Method: Interpreter>>transfer:fromIndex:ofObject:toIndex:ofObject: (in category 'utilities') -----
  transfer: count fromIndex: firstFrom ofObject: fromOop toIndex: firstTo ofObject: toOop
  "Transfer the specified fullword fields, as from calling context to called context"
 
  "Assume: beRootIfOld: will be called on toOop."
  | fromIndex toIndex lastFrom |
  self flag: #Dan.  "Need to check all senders before converting this for 64 bits"
  self inline: true.
+ fromIndex := fromOop + (firstFrom * self bytesPerWord).
+ toIndex := toOop + (firstTo * self bytesPerWord).
+ lastFrom := fromIndex + (count * self bytesPerWord).
- fromIndex := fromOop + (firstFrom * BytesPerWord).
- toIndex := toOop + (firstTo * BytesPerWord).
- lastFrom := fromIndex + (count * BytesPerWord).
  [self oop: fromIndex isLessThan: lastFrom]
+ whileTrue: [fromIndex := fromIndex + self bytesPerWord.
+ toIndex := toIndex + self bytesPerWord.
- whileTrue: [fromIndex := fromIndex + BytesPerWord.
- toIndex := toIndex + BytesPerWord.
  self
  longAt: toIndex
  put: (self longAt: fromIndex)]!

Item was changed:
(excessive method size, no diff calculated)

Item was changed:
  ----- Method: Interpreter>>printNameOfClass:count: (in category 'debug printing') -----
  printNameOfClass: classOop count: cnt
  "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
 
  cnt <= 0 ifTrue: [ ^ self print: 'bad class' ].
+ (self sizeBitsOf: classOop) = (7 * self bytesPerWord) "(Metaclass instSize+1 * 4)"
- (self sizeBitsOf: classOop) = (7 * BytesPerWord) "(Metaclass instSize+1 * 4)"
  ifTrue: [self printNameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop)
  count: cnt - 1.
  self print: ' class']
  ifFalse: [self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop)]!

Item was changed:
  ----- Method: Interpreter>>primitiveIntegerAtPut (in category 'array primitives') -----
  primitiveIntegerAtPut
  "Return the 32bit signed integer contents of a words receiver"
  | index rcvr sz addr value valueOop |
  valueOop := self stackValue: 0.
  index := self stackIntegerValue: 1.
  rcvr := self stackValue: 2.
  (self isIntegerObject: rcvr) ifTrue:[^self success: false].
  (self isWords: rcvr) ifFalse:[^self success: false].
  sz := self lengthOf: rcvr.  "number of fields"
  ((index >= 1) and: [index <= sz]) ifFalse:[^self success: false].
  (self isIntegerObject: valueOop)
  ifTrue:[value := self integerValueOf: valueOop]
  ifFalse:[value := self signed32BitValueOf: valueOop].
  successFlag ifTrue:[
+ addr := rcvr + self baseHeaderSize - 4 "for zero indexing" + (index * 4).
- addr := rcvr + BaseHeaderSize - 4 "for zero indexing" + (index * 4).
  value := self intAt: addr put: value.
  self pop: 3 thenPush: valueOop. "pop all; return value"
  ].
  !

Item was changed:
  ----- Method: Interpreter>>popStack (in category 'contexts') -----
  popStack
 
  | top |
  top := self longAt: stackPointer.
+ stackPointer := stackPointer - self bytesPerWord.
- stackPointer := stackPointer - BytesPerWord.
  ^ top!

Item was changed:
  ----- Method: Interpreter>>imageSegmentVersion (in category 'image segment in/out') -----
  imageSegmentVersion
  | wholeWord |
  "a more complex version that tells both the word reversal and the endianness of the machine it came from.  Low half of word is 6502.  Top byte is top byte of #doesNotUnderstand: on this machine. ($d on the Mac or $s on the PC)"
 
+ wholeWord := self longAt: (self splObj: SelectorDoesNotUnderstand) + self baseHeaderSize.
- wholeWord := self longAt: (self splObj: SelectorDoesNotUnderstand) + BaseHeaderSize.
  "first data word, 'does' "
  ^ self imageFormatVersion bitOr: (wholeWord bitAnd: 16rFF000000)!

Item was changed:
  ----- Method: Interpreter>>floatValueOf: (in category 'utilities') -----
  floatValueOf: oop
  "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
  "Note: May be called by translated primitive code."
 
  | result |
  self flag: #Dan.  "None of the float stuff has been converted for 64 bits"
  self returnTypeC: 'double'.
  self var: #result type: 'double '.
  self assertClassOf: oop is: (self splObj: ClassFloat).
  successFlag
  ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: oop + self baseHeaderSize into: result]
- self fetchFloatAt: oop + BaseHeaderSize into: result]
  ifFalse: [result := 0.0].
  ^ result!

Item was changed:
  ----- Method: ObjectMemory>>fwdTableSize: (in category 'gc -- compaction') -----
  fwdTableSize: blkSize
  "Estimate the number of forwarding blocks available for compaction"
  | eom fwdFirst fwdLast |
  self inline: false.
 
+ eom := freeBlock + self baseHeaderSize.
- eom := freeBlock + BaseHeaderSize.
  "use all memory free between freeBlock and memoryLimit for forwarding table"
 
  "Note: Forward blocks must be quadword aligned."
+ fwdFirst := (eom + self baseHeaderSize + 7) bitAnd: self wordMask - 7.
- fwdFirst := (eom + BaseHeaderSize + 7) bitAnd: WordMask-7.
  self flag: #Dan.  "Above line does not do what it says (quadword is 16 or 32 bytes)"
 
  fwdLast := memoryLimit - blkSize.  "last forwarding table entry"
 
  "return the number of forwarding blocks available"
  ^ (fwdLast - fwdFirst) // blkSize  "round down"!

Item was changed:
  ----- Method: ObjectMemory>>finalizeReference: (in category 'finalization') -----
  finalizeReference: oop
  "During sweep phase we have encountered a weak reference.
  Check if  its object has gone away (or is about to) and if so, signal a
  semaphore. "
  "Do *not* inline this in sweepPhase - it is quite an unlikely
  case to run into a weak reference"
  | weakOop oopGone chunk firstField lastField |
  self inline: false.
  self var: #oop type: 'usqInt'.
  self var: #weakOop type: 'usqInt'.
+ firstField := self baseHeaderSize + ((self nonWeakFieldsOf: oop) << self shiftForWord).
- firstField := BaseHeaderSize + ((self nonWeakFieldsOf: oop) << ShiftForWord).
  lastField := self lastPointerOf: oop.
+ firstField to: lastField by: self bytesPerWord do: [:i |
- firstField to: lastField by: BytesPerWord do: [:i |
  weakOop := self longAt: oop + i.
  "ar 1/18/2005: Added oop < youngStart test to make sure we're not testing
  objects in non-GCable region. This could lead to a forward reference in
  old space with the oop pointed to not being marked and thus treated as free."
  (weakOop == nilObj or: [(self isIntegerObject: weakOop) or:[weakOop < youngStart]])
 
  ifFalse: ["Check if the object is being collected.
  If the weak reference points  
  * backward: check if the weakOops chunk is free
  * forward: check if the weakOoop has been marked by GC"
  weakOop < oop
  ifTrue: [chunk := self chunkFromOop: weakOop.
  oopGone := ((self longAt: chunk) bitAnd: TypeMask) = HeaderTypeFree]
+ ifFalse: [oopGone := ((self baseHeader: weakOop) bitAnd: self markBit) = 0].
- ifFalse: [oopGone := ((self baseHeader: weakOop) bitAnd: MarkBit) = 0].
  oopGone ifTrue: ["Store nil in the pointer and signal the  interpreter "
  self longAt: oop + i put: nilObj.
  self signalFinalization: oop]]]!

Item was changed:
  ----- Method: ObjectMemory>>startObj (in category 'gc -- mark and sweep') -----
  startObj
  "Start tracing the object 'child' and answer the next action.
  The object may be anywhere in the middle of being swept
  itself. See comment in markAndTrace for explanation of
  tracer state variables."
  | oop header lastFieldOffset |
  self inline: true.
  oop := child.
  (self oop: oop isLessThan: youngStartLocal)
  ifTrue: ["old object; skip it"
  field := oop.
  ^ Upward].
  header := self longAt: oop.
+ (header bitAnd: self markBit) = 0
- (header bitAnd: MarkBit) = 0
  ifTrue: ["unmarked; mark and trace"
  "Do not trace the object's indexed fields if it's a weak class "
  (self isWeakNonInt: oop)
  ifTrue: ["Set lastFieldOffset before the weak fields in the receiver "
+ lastFieldOffset := (self nonWeakFieldsOf: oop) << self shiftForWord]
- lastFieldOffset := (self nonWeakFieldsOf: oop) << ShiftForWord]
  ifFalse: ["Do it the usual way"
  lastFieldOffset := self lastPointerOf: oop].
+ header := header bitAnd: self allButTypeMask.
+ header := (header bitOr: self markBit) bitOr: HeaderTypeGC.
- header := header bitAnd: AllButTypeMask.
- header := (header bitOr: MarkBit) bitOr: HeaderTypeGC.
  self longAt: oop put: header.
  field := oop + lastFieldOffset.
  ^ StartField "trace its fields and class"]
  ifFalse: ["already marked; skip it"
  field := oop.
  ^ Upward]!

Item was changed:
  ----- Method: Interpreter>>storeContextRegisters: (in category 'contexts') -----
  storeContextRegisters: activeCntx
  "Note: internalStoreContextRegisters: should track changes to this method."
 
  "InstructionPointer is a pointer variable equal to
+ method oop + ip + self baseHeaderSize
- method oop + ip + BaseHeaderSize
  -1 for 0-based addressing of fetchByte
  -1 because it gets incremented BEFORE fetching currentByte"
 
  self inline: true.
  self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
+ withValue: (self integerObjectOf: (instructionPointer - method - (self baseHeaderSize - 2))).
- withValue: (self integerObjectOf: (instructionPointer - method - (BaseHeaderSize - 2))).
  self storePointerUnchecked: StackPointerIndex ofObject: activeCntx
  withValue: (self integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)).
  !

Item was changed:
  ----- Method: ObjectMemory>>storePointer:ofObject:withValue: (in category 'interpreter access') -----
  storePointer: fieldIndex ofObject: oop withValue: valuePointer
  "Note must check here for stores of young objects into old ones."
 
  (self oop: oop isLessThan: youngStart) ifTrue: [
  self possibleRootStoreInto: oop value: valuePointer.
  ].
 
+ ^ self longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord)
- ^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)
  put: valuePointer!

Item was changed:
  ----- Method: Interpreter>>assertClassOf:is: (in category 'utilities') -----
  assertClassOf: oop is: classOop
  "Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer."
 
  | ccIndex cl |
  self inline: true.
  (self isIntegerObject: oop)
  ifTrue: [ successFlag := false. ^ nil ].
 
  ccIndex := ((self baseHeader: oop) >> 12) bitAnd: 16r1F.
  ccIndex = 0
+ ifTrue: [ cl := ((self classHeader: oop) bitAnd: self allButTypeMask) ]
- ifTrue: [ cl := ((self classHeader: oop) bitAnd: AllButTypeMask) ]
  ifFalse: [
  "look up compact class"
  cl := (self fetchPointer: (ccIndex - 1)
  ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop))].
 
  self success: cl = classOop.
  !

Item was added:
+ ----- Method: ObjectMemory>>allButMarkBit (in category 'constants') -----
+ allButMarkBit
+ "Mask for mark bit"
+
+ self inline: true.
+ ^self
+ cCode: 'ALL_BUT_MARK_BIT'
+ inSmalltalk: [self wordMask - self markBit]
+ !

Item was added:
+ ----- Method: ObjectMemory>>smallContextSize (in category 'constants') -----
+ smallContextSize
+ "16 indexable fields, calculated as ContextFixedSizePlusHeader + 16 * BytesPerWord"
+
+ self inline: true.
+ ^self
+ cCode: 'SMALL_CONTEXT_SIZE'
+ inSmalltalk: [ContextFixedSizePlusHeader + 16 * self bytesPerWord]
+ !

Item was changed:
  ----- Method: ObjectMemory>>startField (in category 'gc -- mark and sweep') -----
  startField
  "Examine and possibly trace the next field of the object being
  traced. See comment in markAndTrace for explanation of
  tracer state variables."
  | typeBits childType |
  self inline: true.
  child := self longAt: field.
  typeBits := child bitAnd: TypeMask.
  (typeBits bitAnd: 1) = 1
  ifTrue: ["field contains a SmallInteger; skip it"
+ field := field - self bytesPerWord.
- field := field - BytesPerWord.
  ^ StartField].
  typeBits = 0 ifTrue: ["normal oop, go down"
  self longAt: field put: parentField.
  parentField := field.
  ^ StartObj].
  typeBits = 2 ifTrue: ["reached the header; do we need to process the class word? "
  (child bitAnd: CompactClassMask) ~= 0
  ifTrue: ["object's class is compact; we're done"
  "restore the header type bits"
+ child := child bitAnd: self allButTypeMask.
- child := child bitAnd: AllButTypeMask.
  childType := self rightType: child.
  self longAt: field put: (child bitOr: childType).
  ^ Upward]
  ifFalse: ["object has a full class word; process that class"
+ child := self longAt: field - self bytesPerWord. "class word"
+ child := child bitAnd: self allButTypeMask. "clear type bits"
+ self longAt: field - self bytesPerWord put: parentField.
+ parentField := field - self bytesPerWord bitOr: 1.
- child := self longAt: field - BytesPerWord. "class word"
- child := child bitAnd: AllButTypeMask. "clear type bits"
- self longAt: field - BytesPerWord put: parentField.
- parentField := field - BytesPerWord bitOr: 1.
  "point at class word; mark as working on the class. "
  ^ StartObj]]!

Item was changed:
  ----- Method: Interpreter>>balancedStack:afterPrimitive:withArgs: (in category 'debug support') -----
  balancedStack: delta afterPrimitive: primIdx withArgs: nArgs
  "Return true if the stack is still balanced after executing primitive primIndex with nArgs args. Delta is 'stackPointer - activeContext' which is a relative measure for the stack pointer (so we don't have to relocate it during the primitive)"
  (primIdx >= 81 and:[primIdx <= 88]) ifTrue:[^true].
  "81-88 are control primitives after which the stack may look unbalanced"
  successFlag ifTrue:[
  "Successful prim, stack must have exactly nArgs arguments popped off"
+ ^(stackPointer - activeContext + (nArgs * self bytesPerWord)) = delta
- ^(stackPointer - activeContext + (nArgs * BytesPerWord)) = delta
  ].
  "Failed prim must leave stack intact"
  ^(stackPointer - activeContext) = delta
  !

Item was changed:
  ----- Method: ObjectMemory>>clone: (in category 'allocation') -----
  clone: oop
  "Return a shallow copy of the given object. May cause GC"
  "Assume: Oop is a real object, not a small integer."
 
  | extraHdrBytes bytes newChunk remappedOop fromIndex toIndex lastFrom newOop header hash |
  self inline: false.
  self var: #lastFrom type: 'usqInt'.
  self var: #fromIndex type: 'usqInt'.
  extraHdrBytes := self extraHeaderBytes: oop.
  bytes := self sizeBitsOf: oop.
  bytes := bytes + extraHdrBytes.
 
  "allocate space for the copy, remapping oop in case of a GC"
  self pushRemappableOop: oop.
  "check it is safe to allocate this much memory. Return 0 if not"
  (self sufficientSpaceToAllocate: 2500 + bytes) ifFalse:[^0].
  newChunk := self allocateChunk: bytes.
  remappedOop := self popRemappableOop.
 
  "copy old to new including all header words"
+ toIndex := newChunk - self bytesPerWord.  "loop below uses pre-increment"
+ fromIndex := (remappedOop - extraHdrBytes) - self bytesPerWord.
- toIndex := newChunk - BytesPerWord.  "loop below uses pre-increment"
- fromIndex := (remappedOop - extraHdrBytes) - BytesPerWord.
  lastFrom := fromIndex + bytes.
  [fromIndex < lastFrom] whileTrue: [
+ self longAt: (toIndex := toIndex + self bytesPerWord) put: (self longAt: (fromIndex := fromIndex + self bytesPerWord))].
- self longAt: (toIndex := toIndex + BytesPerWord) put: (self longAt: (fromIndex := fromIndex + BytesPerWord))].
  newOop := newChunk + extraHdrBytes.  "convert from chunk to oop"
 
  "fix base header: compute new hash and clear Mark and Root bits"
  hash := self newObjectHash.
  header := (self longAt: newOop) bitAnd: 16r1FFFF.
  "use old ccIndex, format, size, and header-type fields"
  header := header bitOr: ((hash << 17) bitAnd: 16r1FFE0000).
  self longAt: newOop put: header.
  ^newOop
  !

Item was changed:
  ----- Method: ObjectMemory>>classHeader: (in category 'header access') -----
  classHeader: oop
 
+ ^ self longAt: oop - self baseHeaderSize!
- ^ self longAt: oop - BaseHeaderSize!

Item was changed:
  ----- Method: Interpreter>>byteSwapped: (in category 'image save/restore') -----
  byteSwapped: w
  "Answer the given integer with its bytes in the reverse order."
 
  self inline: true.
+ self isDefinedTrueExpression: 'BYTES_PER_WORD == 4'
+ inSmalltalk: [self bytesPerWord = 4]
- self isDefinedTrueExpression: 'SQ_VI_BYTES_PER_WORD == 4'
- inSmalltalk: [BytesPerWord = 4]
  comment: 'swap bytes in an object word'
  ifTrue:
  [^ ((w bitShift: Byte3ShiftNegated) bitAnd: Byte0Mask)
  + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte1Mask)
  + ((w bitShift: Byte1Shift         ) bitAnd: Byte2Mask)
  + ((w bitShift: Byte3Shift         ) bitAnd: Byte3Mask)]
  ifFalse:
  [^ ((w bitShift: Byte7ShiftNegated) bitAnd: Byte0Mask)
  + ((w bitShift: Byte5ShiftNegated) bitAnd: Byte1Mask)
  + ((w bitShift: Byte3ShiftNegated) bitAnd: Byte2Mask)
  + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte3Mask)
  + ((w bitShift: Byte1Shift         ) bitAnd: Byte4Mask)
  + ((w bitShift: Byte3Shift         ) bitAnd: Byte5Mask)
  + ((w bitShift: Byte5Shift         ) bitAnd: Byte6Mask)
  + ((w bitShift: Byte7Shift         ) bitAnd: Byte7Mask)]!

Item was changed:
  ----- Method: Interpreter>>internalActivateNewMethod (in category 'message sending') -----
  internalActivateNewMethod
  | methodHeader newContext tempCount argCount2 needsLarge where |
  self inline: true.
 
  methodHeader := self headerOf: newMethod.
  needsLarge := methodHeader bitAnd: LargeContextBit.
  (needsLarge = 0 and: [freeContexts ~= NilContext])
  ifTrue: [newContext := freeContexts.
  freeContexts := self fetchPointer: 0 ofObject: newContext]
  ifFalse: ["Slower call for large contexts or empty free list"
  self externalizeIPandSP.
  newContext := self allocateOrRecycleContext: needsLarge.
  self internalizeIPandSP].
  tempCount := (methodHeader >> 19) bitAnd: 16r3F.
 
  "Assume: newContext will be recorded as a root if necessary by the
  call to newActiveContext: below, so we can use unchecked stores."
+ where :=   newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord)
+ put: (self integerObjectOf: (((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1)).
+ self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
+ self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj.
- where :=   newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << ShiftForWord)
- put: (self integerObjectOf: (((LiteralStart + (self literalCountOfHeader: methodHeader)) * BytesPerWord) + 1)).
- self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.
- self longAt: where + (ClosureIndex << ShiftForWord) put: nilObj.
 
  "Copy the receiver and arguments..."
  argCount2 := argumentCount.
  0 to: argCount2 do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self internalStackValue: argCount2-i)].
- [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self internalStackValue: argCount2-i)].
 
  "clear remaining temps to nil in case it has been recycled"
  methodHeader := nilObj.  "methodHeader here used just as faster (register?) temp"
  argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do:
+ [:i | self longAt: where + (i << self shiftForWord) put: methodHeader].
- [:i | self longAt: where + (i << ShiftForWord) put: methodHeader].
 
  self internalPop: argCount2 + 1.
  reclaimableContextCount := reclaimableContextCount + 1.
  self internalNewActiveContext: newContext.
   !

Item was changed:
  ----- Method: ObjectMemory>>adjustFieldsAndClassOf:by: (in category 'initialization') -----
  adjustFieldsAndClassOf: oop by: offsetBytes
  "Adjust all pointers in this object by the given offset."
  | fieldAddr fieldOop classHeader newClassOop |
  self inline: true.
  offsetBytes = 0 ifTrue: [^nil].
  fieldAddr := oop + (self lastPointerOf: oop).
  [self oop: fieldAddr isGreaterThan: oop]
  whileTrue: [fieldOop := self longAt: fieldAddr.
  (self isIntegerObject: fieldOop)
  ifFalse: [self longAt: fieldAddr put: fieldOop + offsetBytes].
+ fieldAddr := fieldAddr - self bytesPerWord].
- fieldAddr := fieldAddr - BytesPerWord].
  (self headerType: oop) ~= HeaderTypeShort
  ifTrue: ["adjust class header if not a compact class"
+ classHeader := self longAt: oop - self bytesPerWord.
+ newClassOop := (classHeader bitAnd: self allButTypeMask) + offsetBytes.
+ self longAt: oop - self bytesPerWord put: (newClassOop bitOr: (classHeader bitAnd: TypeMask))]!
- classHeader := self longAt: oop - BytesPerWord.
- newClassOop := (classHeader bitAnd: AllButTypeMask) + offsetBytes.
- self longAt: oop - BytesPerWord put: (newClassOop bitOr: (classHeader bitAnd: TypeMask))]!

Item was changed:
  ----- Method: ObjectMemory>>sizeBitsOf: (in category 'header access') -----
  sizeBitsOf: oop
  "Answer the number of bytes in the given object, including its base header, rounded up to an integral number of words."
  "Note: byte indexable objects need to have low bits subtracted from this size."
 
  | header |
  header := self baseHeader: oop.
  (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [ ^ (self sizeHeader: oop) bitAnd: self longSizeMask ]
+ ifFalse: [ ^ header bitAnd: self sizeMask ].!
- ifTrue: [ ^ (self sizeHeader: oop) bitAnd: LongSizeMask ]
- ifFalse: [ ^ header bitAnd: SizeMask ].!

Item was changed:
  ----- Method: Interpreter>>roomToPushNArgs: (in category 'primitive support') -----
  roomToPushNArgs: n
  "Answer if there is room to push n arguments onto the current stack.
  There may be room in this stackPage but there may not be room if
  the frame were converted into a context."
  | cntxSize |
  ((self headerOf: method) bitAnd: LargeContextBit) ~= 0
+ ifTrue: [cntxSize := self largeContextSize / self bytesPerWord - ReceiverIndex]
+ ifFalse: [cntxSize := self smallContextSize / self bytesPerWord - ReceiverIndex].
- ifTrue: [cntxSize := LargeContextSize / BytesPerWord - ReceiverIndex]
- ifFalse: [cntxSize := SmallContextSize / BytesPerWord - ReceiverIndex].
  ^self stackPointerIndex + n <= cntxSize!

Item was changed:
  ----- Method: CCodeGenerator>>generateBytesPerWord:on:indent: (in category 'C translation') -----
  generateBytesPerWord: msgNode on: aStream indent: level
  "Generate the C code for this message onto the given stream."
 
+ aStream nextPutAll: 'BYTES_PER_WORD'
- aStream nextPutAll: ' ', ObjectMemory bytesPerWord asString
  !

Item was changed:
  ----- Method: Interpreter>>makePointwithxValue:yValue: (in category 'utilities') -----
  makePointwithxValue: xValue yValue: yValue
  "make a Point xValue@yValue.
  We know both will be integers so no value nor root checking is needed"
  | pointResult |
+ pointResult := self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3 * self bytesPerWord.
- pointResult := self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3*BytesPerWord.
  self storePointerUnchecked: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue).
  self storePointerUnchecked: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue).
  ^ pointResult!

Item was changed:
  ----- Method: ObjectMemory>>sizeBitsOfSafe: (in category 'header access') -----
  sizeBitsOfSafe: oop
  "Compute the size of the given object from the cc and size fields in its header. This works even if its type bits are not correct."
 
  | header type |
  header := self baseHeader: oop.
  type := self rightType: header.
  type = HeaderTypeSizeAndClass
+ ifTrue: [ ^ (self sizeHeader: oop) bitAnd: self allButTypeMask ]
+ ifFalse: [ ^ header bitAnd: self sizeMask ].!
- ifTrue: [ ^ (self sizeHeader: oop) bitAnd: AllButTypeMask ]
- ifFalse: [ ^ header bitAnd: SizeMask ].!

Item was added:
+ ----- Method: ObjectMemory>>largeContextSize (in category 'constants') -----
+ largeContextSize
+ "Large contexts have 56 indexable fields.  Max with single header word.
+ However note that in 64 bits, for now, large contexts have 3-word headers"
+
+ self inline: true.
+ ^self
+ cCode: 'LARGE_CONTEXT_SIZE'
+ inSmalltalk: [ContextFixedSizePlusHeader + 56 * self bytesPerWord]
+ !

Item was changed:
  ----- Method: ObjectMemory>>allocateChunk: (in category 'allocation') -----
  allocateChunk: byteSize
  "Allocate a chunk of the given size. Sender must be sure that  the requested size includes enough space for the header  word(s). "
  "Details: To limit the time per incremental GC, do one every so many allocations. The number is settable via primitiveVMParameter to tune your memory system"
  | enoughSpace newFreeSize newChunk |
  self inline: true.
 
  allocationCount >= allocationsBetweenGCs
  ifTrue: ["do an incremental GC every so many allocations to  keep pauses short"
  self incrementalGC].
 
  enoughSpace := self sufficientSpaceToAllocate: byteSize.
  enoughSpace
  ifFalse: ["signal that space is running low, but proceed with allocation if possible"
  signalLowSpace := true.
  lowSpaceThreshold := 0. "disable additional interrupts until lowSpaceThreshold is reset by image"
  self saveProcessSignalingLowSpace.
  self forceInterruptCheck].
+ (self oop: (self sizeOfFree: freeBlock) isLessThan: byteSize + self baseHeaderSize)
- (self oop: (self sizeOfFree: freeBlock) isLessThan: byteSize + BaseHeaderSize)
  ifTrue: [self error: 'out of memory'].
 
  "if we get here, there is enough space for allocation to  succeed "
  newFreeSize := (self sizeOfFree: freeBlock) - byteSize.
  newChunk := freeBlock.
  freeBlock := freeBlock + byteSize.
 
  "Assume: client will initialize object header of free chunk, so following is not needed:"
  "self setSizeOfFree: newChunk to: byteSize."
  self setSizeOfFree: freeBlock to: newFreeSize.
  allocationCount := allocationCount + 1.
  ^newChunk!

Item was changed:
  ----- Method: ObjectMemory>>fetchLong32:ofObject: (in category 'interpreter access') -----
  fetchLong32: fieldIndex ofObject: oop
  " index by 32-bit units, and return a 32-bit value. Intended to replace fetchWord:ofObject:"
 
+ ^ self long32At: oop + self baseHeaderSize + (fieldIndex << 2)!
- ^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2)!

Item was changed:
  ----- Method: ObjectMemory>>remap: (in category 'gc -- compaction') -----
  remap: oop
  "Map the given oop to its new value during a compaction or
  become: operation. If it has no forwarding table entry,
  return the oop itself."
  | fwdBlock |
  self inline: false.
  (self isObjectForwarded: oop)
  ifTrue: ["get the new value for oop from its forwarding block"
+ fwdBlock := ((self longAt: oop) bitAnd: self allButMarkBitAndTypeMask) << 1.
- fwdBlock := ((self longAt: oop) bitAnd: AllButMarkBitAndTypeMask) << 1.
  DoAssertionChecks
  ifTrue: [self fwdBlockValidate: fwdBlock].
  ^ self longAt: fwdBlock].
  ^ oop!

Item was changed:
  ----- Method: ObjectMemory>>lastPointerOf: (in category 'object enumeration') -----
  lastPointerOf: oop
  "Return the byte offset of the last pointer field of the given object.  
  Works with CompiledMethods, as well as ordinary objects.
  Can be used even when the type bits are not correct."
  | fmt sz methodHeader header contextSize |
  self inline: true.
  header := self baseHeader: oop.
  fmt := header >> 8 bitAnd: 15.
  fmt <= 4 ifTrue: [(fmt = 3 and: [self isContextHeader: header])
  ifTrue: ["contexts end at the stack pointer"
  contextSize := self fetchStackPointerOf: oop.
+ ^ CtxtTempFrameStart + contextSize * self bytesPerWord].
- ^ CtxtTempFrameStart + contextSize * BytesPerWord].
  sz := self sizeBitsOfSafe: oop.
+ ^ sz - self baseHeaderSize  "all pointers"].
- ^ sz - BaseHeaderSize  "all pointers"].
  fmt < 12 ifTrue: [^ 0]. "no pointers"
 
  "CompiledMethod: contains both pointers and bytes:"
+ methodHeader := self longAt: oop + self baseHeaderSize.
+ ^ (methodHeader >> 10 bitAnd: 255) * self bytesPerWord + self baseHeaderSize!
- methodHeader := self longAt: oop + BaseHeaderSize.
- ^ (methodHeader >> 10 bitAnd: 255) * BytesPerWord + BaseHeaderSize!

Item was changed:
(excessive method size, no diff calculated)

Item was changed:
  ----- Method: Interpreter>>stackFloatValue: (in category 'contexts') -----
  stackFloatValue: offset
  "Note: May be called by translated primitive code."
  | result floatPointer |
  self returnTypeC: 'double'.
  self var: #result type: 'double '.
+ floatPointer := self longAt: stackPointer - (offset * self bytesPerWord).
- floatPointer := self longAt: stackPointer - (offset*BytesPerWord).
  (self fetchClassOf: floatPointer) = (self splObj: ClassFloat)
  ifFalse:[self primitiveFail. ^0.0].
  self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: floatPointer + self baseHeaderSize into: result.
- self fetchFloatAt: floatPointer + BaseHeaderSize into: result.
  ^ result!

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."
 
  | hash header1 header2 cClass byteSize format binc header3 hdrSize fillWord newObj sizeHiBits bm1 classFormat |
  self inline: false.
  DoAssertionChecks ifTrue: [size < 0
  ifTrue: [self error: '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 << HashBitsOffset bitAnd: HashBits).
  header2 := classPointer.
  header3 := 0.
  sizeHiBits := (classFormat bitAnd: 16r60000) >> 9.
  cClass := header1 bitAnd: CompactClassMask. "compact class field from format word"
+ byteSize := (classFormat bitAnd: self sizeMask + self size4Bit) + sizeHiBits.
- 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 << (self shiftForWord - 2).
- byteSize := byteSize << (ShiftForWord-2).
  format := classFormat >> 8 bitAnd: 15.
  self flag: #sizeLowBits.
  format < 8
  ifTrue:
  [format = 6
  ifTrue: ["long32 bitmaps"
+ bm1 := self bytesPerWord - 1.
+ byteSize := byteSize + (size * 4) + bm1 bitAnd: self longSizeMask. "round up"
- 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 * self bytesPerWord) "Arrays and 64-bit bitmaps"]
- ifFalse: [byteSize := byteSize + (size * BytesPerWord) "Arrays and 64-bit bitmaps"]
  ]
  ifFalse:
  ["Strings and Methods"
+ bm1 := self bytesPerWord - 1.
+ byteSize := byteSize + size + bm1 bitAnd: self longSizeMask. "round up"
- 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]].
  format <= 4
  ifTrue: ["if pointers, fill with nil oop"
  fillWord := nilObj]
  ifFalse: [fillWord := 0].
  newObj := self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true with: fillWord.
  ^ newObj!

Item was changed:
  ----- Method: Interpreter>>verifyCleanHeaders (in category 'debug support') -----
  verifyCleanHeaders
  | oop |
  oop := self firstObject.
  [self oop: oop isLessThan: endOfMemory] whileTrue:
  [(self isFreeObject: oop)
  ifTrue: ["There should only be one free block at end of memory."
  (self objectAfter: oop) = endOfMemory
  ifFalse: [self error: 'Invalid obj with HeaderTypeBits = Free.']]
+ ifFalse: [((self longAt: oop) bitAnd: self markBit) = 0
- ifFalse: [((self longAt: oop) bitAnd: MarkBit) = 0
  ifFalse: [self error: 'Invalid obj with MarkBit set.']].
  oop := self objectAfter: oop]!

Item was changed:
(excessive method size, no diff calculated)

Item was changed:
  ----- Method: Interpreter>>internalPop:thenPush: (in category 'contexts') -----
  internalPop: nItems thenPush: oop
 
+ self longAtPointer: (localSP := localSP - ((nItems - 1) * self bytesPerWord)) put: oop.
- self longAtPointer: (localSP := localSP - ((nItems - 1) * BytesPerWord)) put: oop.
  !

Item was changed:
  ----- Method: Interpreter>>stackValue: (in category 'contexts') -----
  stackValue: offset
+ ^ self longAt: stackPointer - (offset * self bytesPerWord)!
- ^ self longAt: stackPointer - (offset*BytesPerWord)!

Item was changed:
  ----- Method: Interpreter>>initialCleanup (in category 'initialization') -----
  initialCleanup
  "Images written by VMs earlier than 3.6/3.7 will wrongly have the root bit set on the active context. Besides clearing the root bit, we treat this as a marker that these images also lack a cleanup of external primitives (which has been introduced at the same time when the root bit problem was fixed). In this case, we merely flush them from here."
 
+ ((self longAt: activeContext) bitAnd: self rootBit) = 0 ifTrue:[^nil]. "root bit is clean"
- ((self longAt: activeContext) bitAnd: RootBit) = 0 ifTrue:[^nil]. "root bit is clean"
  "Clean root bit of activeContext"
+ self longAt: activeContext put: ((self longAt: activeContext) bitAnd: self allButRootBit).
- self longAt: activeContext put: ((self longAt: activeContext) bitAnd: AllButRootBit).
  "Clean external primitives"
  self flushExternalPrimitives.!

Item was changed:
  ----- Method: InterpreterSimulator>>validate: (in category 'testing') -----
  validate: oop
  | header type cc sz fmt nextChunk |
  header := self longAt: oop.
  type := header bitAnd: 3.
  type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]].
+ sz := (header bitAnd: self sizeMask) >> 2.
- sz := (header bitAnd: SizeMask) >> 2.
  (self isFreeObject: oop)
  ifTrue: [ nextChunk := oop + (self sizeOfFree: oop) ]
  ifFalse: [  nextChunk := oop + (self sizeBitsOf: oop) ].
  nextChunk > endOfMemory
  ifTrue: [oop = endOfMemory ifFalse: [self halt]].
  (self headerType: nextChunk) = 0 ifTrue: [
  (self headerType: (nextChunk + (BytesPerWord*2))) = 0 ifFalse: [self halt]].
  (self headerType: nextChunk) = 1 ifTrue: [
  (self headerType: (nextChunk + BytesPerWord)) = 1 ifFalse: [self halt]].
  type = 2 ifTrue:
  ["free block" ^ self].
  fmt := (header >> 8) bitAnd: 16rF.
  cc := (header >> 12) bitAnd: 31.
  cc > 16 ifTrue: [self halt]. "up to 32 are legal, but not used"
  type = 0 ifTrue:
  ["three-word header"
  ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
  ((self longAt: oop-(BytesPerWord*2)) bitAnd: 3) = type ifFalse: [self halt].
  ((self longAt: oop-BytesPerWord) = type) ifTrue: [self halt]. "Class word is 0"
  sz = 0 ifFalse: [self halt]].
  type = 1 ifTrue:
  ["two-word header"
  ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
  cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]].
  sz = 0 ifTrue: [self halt]].
  type = 3 ifTrue:
  ["one-word header"
  cc = 0 ifTrue: [self halt]].
  fmt = 5 ifTrue: [self halt].
  fmt = 7 ifTrue: [self halt].
  fmt >= 12 ifTrue:
  ["CompiledMethod -- check for integer header"
  (self isIntegerObject: (self longAt: oop + BytesPerWord)) ifFalse: [self halt]].!

Item was changed:
  ----- Method: Interpreter>>oopHasAcceptableClass: (in category 'image segment in/out') -----
  oopHasAcceptableClass: signedOop
  "Similar to oopHasOkayClass:, except that it only returns true or false."
 
  | oopClass formatMask behaviorFormatBits oopFormatBits oop |
  (self isIntegerObject: signedOop) ifTrue: [^ true].
 
  self var: #oop type: 'usqInt'.
  self var: #oopClass type: 'usqInt'.
 
  oop := self cCoerce: signedOop to: 'usqInt'.
 
  oop < endOfMemory ifFalse: [^ false].
+ ((oop \\ self bytesPerWord) = 0) ifFalse: [^ false].
- ((oop \\ BytesPerWord) = 0) ifFalse: [^ false].
  (oop + (self sizeBitsOf: oop)) < endOfMemory ifFalse: [^ false].
  oopClass := self cCoerce: (self fetchClassOf: oop) to: 'usqInt'.
 
  (self isIntegerObject: oopClass) ifTrue: [^ false].
  (oopClass < endOfMemory) ifFalse: [^ false].
+ ((oopClass \\ self bytesPerWord) = 0) ifFalse: [^ false].
- ((oopClass \\ BytesPerWord) = 0) ifFalse: [^ false].
  (oopClass + (self sizeBitsOf: oopClass)) < endOfMemory ifFalse: [^ false].
  ((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [^ false].
  (self isBytes: oop)
  ifTrue: [ formatMask := 16rC00 ]  "ignore extra bytes size bits"
  ifFalse: [ formatMask := 16rF00 ].
 
  behaviorFormatBits := (self formatOfClass: oopClass) bitAnd: formatMask.
  oopFormatBits := (self baseHeader: oop) bitAnd: formatMask.
  behaviorFormatBits = oopFormatBits ifFalse: [^ false].
  ^ true!

Item was changed:
  ----- Method: ObjectMemory>>incCompBody (in category 'gc -- compaction') -----
  incCompBody
  "Move objects to consolidate free space into one big chunk. Return the newly created free chunk."
 
  | bytesFreed |
  self inline: false.
  "reserve memory for forwarding table"
+ self fwdTableInit: self bytesPerWord * 2.  "Two-word blocks"
- self fwdTableInit: BytesPerWord*2.  "Two-word blocks"
 
  "assign new oop locations, reverse their headers, and initialize forwarding blocks"
  bytesFreed := self incCompMakeFwd.
 
  "update pointers to point at new oops"
  self mapPointersInObjectsFrom: youngStart to: endOfMemory.
 
  "move the objects and restore their original headers; return the new free chunk"
  ^ self incCompMove: bytesFreed!

Item was changed:
  ----- Method: ObjectMemory>>remapFieldsAndClassOf: (in category 'gc -- compaction') -----
  remapFieldsAndClassOf: oop
  "Replace all forwarded pointers in this object with their new oops, using the forwarding table. Remap its class as well, if
  necessary. "
  "Note: The given oop may be forwarded itself, which means that its real header is in its forwarding table entry."
  | fieldOffset fieldOop fwdBlock newOop |
  self inline: true.
  fieldOffset := self lastPointerWhileForwarding: oop.
+ [fieldOffset >= self baseHeaderSize]
- [fieldOffset >= BaseHeaderSize]
  whileTrue: [fieldOop := self longAt: oop + fieldOffset.
  (self isObjectForwarded: fieldOop)
  ifTrue: ["update this oop from its forwarding block"
+ fwdBlock := ((self longAt: fieldOop) bitAnd: self allButMarkBitAndTypeMask) << 1.
- fwdBlock := ((self longAt: fieldOop) bitAnd: AllButMarkBitAndTypeMask) << 1.
  DoAssertionChecks
  ifTrue: [self fwdBlockValidate: fwdBlock].
  newOop := self longAt: fwdBlock.
  self longAt: oop + fieldOffset put: newOop.
  "The following ensures that become: into old object makes it a root.
  It does nothing during either incremental or full compaction because
  oop will never be < youngStart."
  ((self oop: oop isLessThan: youngStart)
  and: [self oop: newOop isGreaterThanOrEqualTo: youngStart])
  ifTrue: [self beRootWhileForwarding: oop]].
+ fieldOffset := fieldOffset - self bytesPerWord].
- fieldOffset := fieldOffset - BytesPerWord].
  self remapClassOf: oop!

Item was changed:
  ----- Method: Interpreter>>primitiveFailAfterCleanup: (in category 'image segment in/out') -----
  primitiveFailAfterCleanup: outPointerArray
  "If the storeSegment primitive fails, it must clean up first."
 
  | i lastAddr |   "Store nils throughout the outPointer array."
  lastAddr := outPointerArray + (self lastPointerOf: outPointerArray).
+ i := outPointerArray + self baseHeaderSize.
- i := outPointerArray + BaseHeaderSize.
  [i <= lastAddr] whileTrue:
  [self longAt: i put: nilObj.
+ i := i + self bytesPerWord].
- i := i + BytesPerWord].
 
  DoAssertionChecks ifTrue: [self verifyCleanHeaders].
  self primitiveFail!

Item was changed:
  ----- Method: Interpreter>>copyObj:toSegment:addr:stopAt:saveOopAt:headerAt: (in category 'image segment in/out') -----
  copyObj: oop toSegment: segmentWordArray addr: lastSeg stopAt: stopAddr saveOopAt: oopPtr headerAt: hdrPtr
  "Copy this object into the segment beginning at lastSeg.
  Install a forwarding pointer, and save oop and header.
  Fail if out of space.  Return the next segmentAddr if successful."
 
  "Copy the object..."
  | extraSize bodySize hdrAddr |
  self flag: #Dan.  "None of the imageSegment stuff has been updated for 64 bits"
  successFlag ifFalse: [^ lastSeg].
  extraSize := self extraHeaderBytes: oop.
  bodySize := self sizeBitsOf: oop.
  (self oop: (lastSeg + extraSize + bodySize) isGreaterThanOrEqualTo: stopAddr)
  ifTrue: [^ self primitiveFail].
+ self transfer: extraSize + bodySize // self bytesPerWord  "wordCount"
- self transfer: extraSize + bodySize // BytesPerWord  "wordCount"
  from: oop - extraSize
+ to: lastSeg + self bytesPerWord.
- to: lastSeg+BytesPerWord.
 
  "Clear root and mark bits of all headers copied into the segment"
+ hdrAddr := lastSeg + self bytesPerWord + extraSize.
+ self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: self allButRootBit - self markBit).
- hdrAddr := lastSeg+BytesPerWord + extraSize.
- self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: AllButRootBit - MarkBit).
 
+ self forward: oop to: (lastSeg + self bytesPerWord + extraSize - segmentWordArray)
- self forward: oop to: (lastSeg+BytesPerWord + extraSize - segmentWordArray)
  savingOopAt: oopPtr andHeaderAt: hdrPtr.
 
  "Return new end of segment"
  ^ lastSeg + extraSize + bodySize!

Item was changed:
+ ----- Method: ObjectMemory>>bytesPerWord (in category 'constants') -----
- ----- Method: ObjectMemory>>bytesPerWord (in category 'initialization') -----
  bytesPerWord
  "Answer the size of an object memory word in bytes."
+ "Class variable shadows the cpp macro definition in generated code."
 
+ self inline: true.
+ ^self cCode: 'BYTES_PER_WORD' inSmalltalk: [BytesPerWord]
+ !
- ^BytesPerWord!

Item was changed:
  ----- Method: ObjectMemory>>allocate:headerSize:h1:h2:h3:doFill:with: (in category 'allocation') -----
  allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord
  "Allocate a new object of the given size and number of header words. (Note: byteSize already includes space for the base header word.) Initialize the header fields of the new object and fill the remainder of the object with the given value.
  May cause a GC"
 
  | newObj remappedClassOop end i |
  self inline: true.
  self var: #i type: 'usqInt'.
  self var: #end type: 'usqInt'.
  "remap classOop in case GC happens during allocation"
  hdrSize > 1 ifTrue: [self pushRemappableOop: classOop].
+ newObj := self allocateChunk: byteSize + (hdrSize - 1 * self bytesPerWord).
- newObj := self allocateChunk: byteSize + (hdrSize - 1 * BytesPerWord).
  hdrSize > 1 ifTrue: [remappedClassOop := self popRemappableOop].
 
  hdrSize = 3
  ifTrue: [self longAt: newObj put: (extendedSize bitOr: HeaderTypeSizeAndClass).
+ self longAt: newObj + self bytesPerWord put: (remappedClassOop bitOr: HeaderTypeSizeAndClass).
+ self longAt: newObj + (self bytesPerWord*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
+ newObj := newObj + (self bytesPerWord*2)].
- self longAt: newObj + BytesPerWord put: (remappedClassOop bitOr: HeaderTypeSizeAndClass).
- self longAt: newObj + (BytesPerWord*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
- newObj := newObj + (BytesPerWord*2)].
 
  hdrSize = 2
  ifTrue: [self longAt: newObj put: (remappedClassOop bitOr: HeaderTypeClass).
+ self longAt: newObj + self bytesPerWord put: (baseHeader bitOr: HeaderTypeClass).
+ newObj := newObj + self bytesPerWord].
- self longAt: newObj + BytesPerWord put: (baseHeader bitOr: HeaderTypeClass).
- newObj := newObj + BytesPerWord].
 
  hdrSize = 1
  ifTrue: [self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort)].
  "clear new object"
  doFill ifTrue: [end := newObj + byteSize.
+ i := newObj + self bytesPerWord.
- i := newObj + BytesPerWord.
  [i < end] whileTrue: [self longAt: i put: fillWord.
+ i := i + self bytesPerWord]].
- i := i + BytesPerWord]].
  DoAssertionChecks
  ifTrue: [self okayOop: newObj.
  self oopHasOkayClass: newObj.
  (self objectAfter: newObj) = freeBlock
  ifFalse: [self error: 'allocate bug: did not set header of new oop correctly'].
  (self objectAfter: freeBlock) = endOfMemory
  ifFalse: [self error: 'allocate bug: did not set header of freeBlock correctly']].
 
  ^newObj!

Item was changed:
  ----- Method: ObjectMemory>>instantiateContext:sizeInBytes: (in category 'interpreter access') -----
  instantiateContext: classPointer sizeInBytes: sizeInBytes
  "This version of instantiateClass assumes that the total object
  size is under 256 bytes, the limit for objects with only one or
  two header words. Note that the size is specified in bytes
  and should include four bytes for the base header word."
  | hash header1 header2 hdrSize |
  hash := self newObjectHash.
  header1 := (hash << HashBitsOffset bitAnd: HashBits) bitOr: (self formatOfClass: classPointer).
  header2 := classPointer.
  (header1 bitAnd: CompactClassMask) > 0 "are contexts compact?"
  ifTrue: [hdrSize := 1]
  ifFalse: [hdrSize := 2].
+ sizeInBytes <= self sizeMask
- sizeInBytes <= SizeMask
  ifTrue: ["OR size into header1.  Must not do this if size > SizeMask"
+ header1 := header1 + (sizeInBytes - (header1 bitAnd: self sizeMask))]
- header1 := header1 + (sizeInBytes - (header1 bitAnd: SizeMask))]
  ifFalse: [hdrSize := 3.
  "Zero the size field of header1 if large"
+ header1 := header1 - (header1 bitAnd: self sizeMask)].
- header1 := header1 - (header1 bitAnd: SizeMask)].
  self flag: #Dan.  "Check details of context sizes"
+ ^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: self largeContextSize doFill: false with: 0!
- ^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: LargeContextSize doFill: false with: 0!

Item was changed:
  ----- Method: ObjectMemory>>instantiateSmallClass:sizeInBytes: (in category 'interpreter access') -----
  instantiateSmallClass: classPointer sizeInBytes: sizeInBytes
  "This version of instantiateClass assumes that the total object
  size is under 256 bytes, the limit for objects with only one or
  two header words. Note that the size is specified in bytes
  and should include 4 or 8 bytes for the base header word.
  NOTE this code will only work for sizes that are an integral number of words
  (like not a 32-bit LargeInteger in a 64-bit system).
  May cause a GC.
  Note that the created small object IS NOT FILLED and must be completed before returning it to Squeak. Since this call is used in routines that do jsut that we are safe. Break this rule and die."
 
  | hash header1 header2 hdrSize |
+ (sizeInBytes bitAnd: (self bytesPerWord - 1)) = 0 ifFalse:
- (sizeInBytes bitAnd: (BytesPerWord-1)) = 0 ifFalse:
  [self error: 'size must be integral number of words'].
  hash := self newObjectHash.
  header1 := (hash << HashBitsOffset bitAnd: HashBits) bitOr: (self formatOfClass: classPointer).
  header2 := classPointer.
  (header1 bitAnd: CompactClassMask) > 0 "is this a compact class"
  ifTrue: [hdrSize := 1]
  ifFalse: [hdrSize := 2].
+ header1 := header1 + (sizeInBytes - (header1 bitAnd: self sizeMask + self size4Bit)).
- header1 := header1 + (sizeInBytes - (header1 bitAnd: SizeMask+Size4Bit)).
  ^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 doFill: false with: 0!

Item was changed:
  ----- Method: Interpreter>>reverseWordsFrom:to: (in category 'image save/restore') -----
  reverseWordsFrom: startAddr to: stopAddr
  "Word-swap the given range of memory, excluding stopAddr."
 
  | addr |
  addr := startAddr.
  [self oop: addr isLessThan: stopAddr] whileTrue:
  [self longAt: addr put: (self wordSwapped: (self longAt: addr)).
+ addr := addr + self bytesPerWord].!
- addr := addr + BytesPerWord].!

Item was changed:
  ----- Method: ObjectMemory>>clearRootsTable (in category 'garbage collection') -----
  clearRootsTable
  "Clear the root bits of the current roots, then empty the roots
  table. "
  "Caution: This should only be done when the young object
  space is empty."
  "reset the roots table (after this, all objects are old so there
  are no roots)"
  | oop |
  1 to: rootTableCount do: [:i |
  "clear root bits of current root table entries"
  oop := rootTable at: i.
+ self longAt: oop put: ((self longAt: oop) bitAnd: self allButRootBit).
- self longAt: oop put: ((self longAt: oop) bitAnd: AllButRootBit).
  rootTable at: i put: 0].
  rootTableCount := 0!

Item was changed:
  ----- Method: VMMaker class>>versionString (in category 'version testing') -----
  versionString
 
  "VMMaker versionString"
 
+ ^'4.2.0'!
- ^'4.1.1'!

Item was changed:
  ----- Method: ObjectMemory>>validateRoots (in category 'memory access') -----
  validateRoots
  "Verify that every old object that points to a new object
  has its root bit set, and
  appears in the rootTable.
  This method should not be called if the rootTable is full, because roots
  are no longer recorded, and incremental collections are not attempted.
  If DoAssertionChecks is true, this routine will halt on an unmarked root.
  Otherwise, this routine will merely return true in that case."
  | oop fieldAddr fieldOop header badRoot |
  self var: #oop type: 'usqInt'.
  self var: #fieldAddr type: 'usqInt'.
  self var: #fieldOop type: 'usqInt'.
  badRoot := false.
  oop := self firstObject.
 
  [oop < youngStart] whileTrue:
  [(self isFreeObject: oop) ifFalse:
  [fieldAddr := oop + (self lastPointerOf: oop).
  [fieldAddr > oop] whileTrue:
  [fieldOop := self longAt: fieldAddr.
  (fieldOop >= youngStart and: [(self isIntegerObject: fieldOop) not]) ifTrue:
  ["fieldOop is a pointer to a young object"
  header := self longAt: oop.
+ (header bitAnd: self rootBit) = 0
- (header bitAnd: RootBit) = 0
  ifTrue:
  ["Forbidden: points to young obj but root bit not set."
  DoAssertionChecks ifTrue: [self error: 'root bit not set'].
  badRoot := true]
  ifFalse:
  ["Root bit is set"
  "Extreme test -- validate that oop was entered in rootTable too..."
  "Disabled for now...
  found := false.
  1 to: rootTableCount do:
  [:i | oop = (rootTable at: i) ifTrue: [found := true]].
  found ifFalse:
  [DoAssertionChecks ifTrue: [self error: 'root table not set'].
  badRoot := true].
  ..."
  ]].
+ fieldAddr := fieldAddr - self bytesPerWord]].
- fieldAddr := fieldAddr - BytesPerWord]].
  oop := self objectAfter: oop].
  ^ badRoot!

Item was removed:
- ----- Method: Array>>coerceTo:sim: (in category '*VMMaker-interpreter simulator') -----
- coerceTo: cTypeString sim: interpreterSimulator
-
- ^ self!