Quantcast

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

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

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

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

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

Name: VMMaker.oscog-eem.2209
Author: eem
Time: 11 May 2017, 2:51:03.00084 pm
UUID: 0705b52b-5f24-4ee5-a3bb-e5c3540b132b
Ancestors: VMMaker.oscog-eem.2208

Spur:
Lift the limits on Spur image segments.  There is now no limit on the number of objects in a segment, but the classes in the segment must occupy no more than 2 ^ 21 bytes (maxIdentityHash / 2 * 8 - which allows for about 1.4 million 11 slot classes), and the segment can have no more than 2 ^ 21 out pointers (again maxIdentityHash / 2.  Tested for simple examples.  manages to export a project but not load it yet.

Fail if the segment store args that are mutated are either immutable or pinned.

Fix bad bug in shorten:toIndexableSize: (which could affect Scorch/Sista).  The old code for addressAfter: would be fooled by an object with overflow slows but fewer slots than numSlotsMask.  So fix addressAfter: so it will still add the overflow header if there is one.

Rewrite objectBytesForSlots: to follow the fixed addressAfter:.  The code should be cleaner.

Fix checkInterpreterIntegrity in the case of the primitiveDoPrimtiive code setting newMethod to an integer.

Fix some translation-timer warnings by tweaking storeLiteralVariable:withValue:, storePointerImmutabilityCheck:ofObject:withValue: & primitiveGetenv.

Simulator:
Discard the simulated implementations of makeDirEntryName:size:createDate:modDate:isDir:fileSize:posixPermissions:[isSymlink:] which are out of sync with the real code, simply defe4rring to the FilePlugin's actual methods.

Slang:
Eliminate halts in the conversion from Smalltalk parse tree to Slang parse tree to allow halts to be left in the simulator code without polluting the generated C.

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

Item was changed:
  ----- Method: CogVMSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'file primitives') -----
  makeDirEntryName: entryName size: entryNameSize
  createDate: createDate modDate: modifiedDate
+ isDir: dirFlag fileSize: fileSize
- isDir: dirFlag fileSize: fileSize
 
+ ^(pluginList
+ detect: [:assoc| assoc key = 'FilePlugin']
+ ifNone: [self error: 'this message should not be sent unless the FilePlugin has been loaded']) value
+ makeDirEntryName: entryName size: entryNameSize
+ createDate: createDate modDate: modifiedDate
+ isDir: dirFlag fileSize: fileSize!
- | modDateOop createDateOop nameString results |
- <var: 'entryName' type: 'char *'>
-
- results := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: 5.
- nameString := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: entryNameSize.
- createDateOop := self positive32BitIntegerFor: createDate.
- modDateOop := self positive32BitIntegerFor: modifiedDate.
-
- 1 to: entryNameSize do:
- [ :i |
- objectMemory storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue].
-
- objectMemory storePointerUnchecked: 0 ofObject: results withValue: nameString.
- objectMemory storePointerUnchecked: 1 ofObject: results withValue: createDateOop.
- objectMemory storePointerUnchecked: 2 ofObject: results withValue: modDateOop.
- dirFlag
- ifTrue: [ objectMemory storePointerUnchecked: 3 ofObject: results withValue: objectMemory trueObject ]
- ifFalse: [ objectMemory storePointerUnchecked: 3 ofObject: results withValue: objectMemory falseObject ].
- objectMemory storePointerUnchecked: 4 ofObject: results withValue: (objectMemory integerObjectOf: fileSize).
- ^ results!

Item was changed:
  ----- Method: CogVMSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize:posixPermissions:isSymlink: (in category 'as yet unclassified') -----
  makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize posixPermissions: posixPermissions isSymlink: symlinkFlag
- <option: #PharoVM>
- <var: 'entryName' type: 'char *'>
 
+ ^(pluginList
+ detect: [:assoc| assoc key = 'FilePlugin']
+ ifNone: [self error: 'this message should not be sent unless the FilePlugin has been loaded']) value
+ makeDirEntryName: entryName size: entryNameSize
+ createDate: createDate modDate: modifiedDate
+ isDir: dirFlag fileSize: fileSize
+ posixPermissions: fileSize isSymlink: symlinkFlag!
- | modDateOop createDateOop nameString results |
-
- results := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: 7.
- nameString := objectMemory instantiateClass: (objectMemory splObj: ClassString) indexableSize: entryNameSize.
- createDateOop := self positive32BitIntegerFor: createDate.
- modDateOop := self positive32BitIntegerFor: modifiedDate.
-
- 1 to: entryNameSize do:
- [ :i |
- objectMemory storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue].
-
- objectMemory storePointerUnchecked: 0 ofObject: results withValue: nameString.
- objectMemory storePointerUnchecked: 1 ofObject: results withValue: createDateOop.
- objectMemory storePointerUnchecked: 2 ofObject: results withValue: modDateOop.
- dirFlag
- ifTrue: [ objectMemory storePointerUnchecked: 3 ofObject: results withValue: objectMemory trueObject ]
- ifFalse: [ objectMemory storePointerUnchecked: 3 ofObject: results withValue: objectMemory falseObject ].
- objectMemory storePointerUnchecked: 4 ofObject: results withValue: (objectMemory integerObjectOf: fileSize).
- objectMemory storePointerUnchecked: 5 ofObject: results withValue: (objectMemory integerObjectOf: posixPermissions).
- symlinkFlag
- ifTrue: [ objectMemory storePointerUnchecked: 6 ofObject: results withValue: objectMemory trueObject ]
- ifFalse: [ objectMemory storePointerUnchecked: 6 ofObject: results withValue: objectMemory falseObject ].
-
- ^ results!

Item was changed:
  ----- Method: FilePlugin>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'directory primitives') -----
  makeDirEntryName: entryName size: entryNameSize
  createDate: createDate modDate: modifiedDate
  isDir: dirFlag fileSize: fileSize
 
  | modDateOop createDateOop nameString results stringPtr fileSizeOop |
  <var: 'entryName' type: 'char *'>
  <var: 'stringPtr' type:'char *'>
  <var: 'fileSize' type:'squeakFileOffsetType '>
 
  "allocate storage for results, remapping newly allocated
  oops in case GC happens during allocation"
  interpreterProxy pushRemappableOop:
- (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 5).
- interpreterProxy pushRemappableOop:
  (interpreterProxy instantiateClass: (interpreterProxy classString) indexableSize: entryNameSize).
  interpreterProxy pushRemappableOop:
  (interpreterProxy positive32BitIntegerFor: createDate).
  interpreterProxy pushRemappableOop:
  (interpreterProxy positive32BitIntegerFor: modifiedDate).
  interpreterProxy pushRemappableOop:
  (interpreterProxy positive64BitIntegerFor: fileSize).
 
+ results := interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 5.
- fileSizeOop   := interpreterProxy popRemappableOop.
- modDateOop   := interpreterProxy popRemappableOop.
- createDateOop := interpreterProxy popRemappableOop.
- nameString    := interpreterProxy popRemappableOop.
- results         := interpreterProxy popRemappableOop.
 
+ fileSizeOop := interpreterProxy popRemappableOop.
+ modDateOop := interpreterProxy popRemappableOop.
+ createDateOop := interpreterProxy popRemappableOop.
+ nameString := interpreterProxy popRemappableOop.
+
  "copy name into Smalltalk string"
  stringPtr := interpreterProxy firstIndexableField: nameString.
+ 0 to: entryNameSize - 1 do:
+ [ :i |
+ self cCode: [stringPtr at: i put: (entryName at: i)]
+ inSmalltalk: [interpreterProxy storeByte: i ofObject: nameString withValue: (entryName at: i+1) asciiValue]].
- 0 to: entryNameSize - 1 do: [ :i |
- stringPtr at: i put: (entryName at: i).
- ].
 
+ interpreterProxy
+ storePointer: 0 ofObject: results withValue: nameString;
+ storePointer: 1 ofObject: results withValue: createDateOop;
+ storePointer: 2 ofObject: results withValue: modDateOop;
+ storePointer: 3 ofObject: results withValue: (dirFlag
+ ifTrue: [interpreterProxy trueObject]
+ ifFalse: [interpreterProxy falseObject]);
+ storePointer: 4 ofObject: results withValue: fileSizeOop.
+ ^results!
- interpreterProxy storePointer: 0 ofObject: results withValue: nameString.
- interpreterProxy storePointer: 1 ofObject: results withValue: createDateOop.
- interpreterProxy storePointer: 2 ofObject: results withValue: modDateOop.
- dirFlag
- ifTrue: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy trueObject ]
- ifFalse: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy falseObject ].
- interpreterProxy storePointer: 4 ofObject: results withValue: fileSizeOop.
- ^ results!

Item was removed:
- ----- Method: FilePluginSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'simulation') -----
- makeDirEntryName: entryName size: entryNameSize
- createDate: createDate modDate: modifiedDate
- isDir: dirFlag fileSize: fileSize
-
- ^interpreterProxy
- makeDirEntryName: entryName size: entryNameSize
- createDate: createDate modDate: modifiedDate
- isDir: dirFlag fileSize: fileSize
- !

Item was removed:
- ----- Method: FilePluginSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize:posixPermissions:isSymlink: (in category 'file primitives') -----
- makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize posixPermissions: posixPermissions isSymlink: symlinkFlag
- "This is used just by the PharoVM, at the moment"
-
- ^interpreterProxy
- makeDirEntryName: entryName
- size: entryNameSize
- createDate: createDate
- modDate: modifiedDate
- isDir: dirFlag
- fileSize: fileSize
- posixPermissions: posixPermissions
- isSymlink: symlinkFlag!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveGetenv (in category 'other primitives') -----
  primitiveGetenv
  "Access to environment variables via getenv.  No putenv or setenv as yet."
  | var result |
  <export: true>
  <var: #var type: #'char *'>
  <var: #result type: #'char *'>
  sHEAFn ~= 0 ifTrue: "secHasEnvironmentAccess"
  [self sHEAFn ifFalse: [^self primitiveFailFor: PrimErrInappropriate]].
  var := self cStringOrNullFor: self stackTop.
  var = 0 ifTrue:
  [self successful ifTrue:
  [^self primitiveFailFor: PrimErrBadArgument].
+ ^self primitiveFailFor: primFailCode].
- ^self].
  result := self getenv: (self cCode: [var] inSmalltalk: [var allButLast]).
  self free: var.
  result ~= 0 ifTrue:
  [result := objectMemory stringForCString: result.
  result ifNil:
  [^self primitiveFailFor: PrimErrNoMemory]].
  self assert: primFailCode = 0.
  self pop: 2 thenPush: (result = 0 ifTrue: [objectMemory nilObject] ifFalse: [result])!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveLoadImageSegment (in category 'image segment in/out') -----
  primitiveLoadImageSegment
+ "This primitive is called from Smalltalk as...
+ <imageSegment> loadSegmentFrom: aWordArray outPointers: anArray.
- "This primitive is called from Squeak as...
- <imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
 
+ This primitive will load a binary image segment created by primitiveStoreImageSegment.
- "This primitive will load a binary image segment created by primitiveStoreImageSegment.
  It expects the outPointer array to be of the proper size, and the wordArray to be well
  formed.  It will return as its value the original array of roots, and the erstwhile
  segmentWordArray will have been truncated to a size of one word, i.e. retaining the version
  stamp.  If this primitive should fail, the segmentWordArray will, sadly, have been reduced to
+ an unrecognizable and unusable jumble.  But what more could you have done with it anyway?
+ [How about saving it so the system functions as primtiives are intended?  eem 5/9/2017 16:31]
- an unrecognizable and unusable jumble.  But what more could you have done with it anyway?"
 
+ In Spur, if the primitive succeeds, the segmentWordArray is also becomed into the array of loaded
+ objects, to allow fixing up of loaded objects directly without nextObject, which Spur doesn't support."
+
  | outPointerArray segmentWordArray result |
 
  outPointerArray := self stackTop.
  segmentWordArray := self stackValue: 1.
 
  "Essential type checks"
  ((objectMemory isArray: outPointerArray) "Must be indexable pointers"
  and: [objectMemory isWords: segmentWordArray]) "Must be indexable words"
  ifFalse: [^self primitiveFail].
 
  "the engine returns the roots array which was first in the segment, or an error code on failure."
  result := objectMemory loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray.
  (self oop: result isGreaterThan: segmentWordArray)
  ifTrue: [self pop: 3 thenPush: result]
  ifFalse: [self primitiveFailFor: result]!

Item was changed:
  ----- Method: InterpreterSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'file primitives') -----
  makeDirEntryName: entryName size: entryNameSize
  createDate: createDate modDate: modifiedDate
+ isDir: dirFlag fileSize: fileSize
- isDir: dirFlag fileSize: fileSize
 
+ ^(pluginList
+ detect: [:assoc| assoc key = 'FilePlugin']
+ ifNone: [self error: 'this message should not be sent unless the FilePlugin has been loaded']) value
+ makeDirEntryName: entryName size: entryNameSize
+ createDate: createDate modDate: modifiedDate
+ isDir: dirFlag fileSize: fileSize!
- | modDateOop createDateOop nameString results |
- <var: 'entryName' type: 'char *'>
-
- "allocate storage for results, remapping newly allocated
- oops in case GC happens during allocation"
- self pushRemappableOop:
- (self instantiateClass: (self splObj: ClassArray) indexableSize: 5).
- self pushRemappableOop:
- (self instantiateClass: (self splObj: ClassByteString) indexableSize: entryNameSize).
- self pushRemappableOop: (self positive32BitIntegerFor: createDate).
- self pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).
-
- modDateOop   := self popRemappableOop.
- createDateOop := self popRemappableOop.
- nameString    := self popRemappableOop.
- results         := self popRemappableOop.
-
- 1 to: entryNameSize do: [ :i |
- self storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
- ].
-
- self storePointer: 0 ofObject: results withValue: nameString.
- self storePointer: 1 ofObject: results withValue: createDateOop.
- self storePointer: 2 ofObject: results withValue: modDateOop.
- dirFlag
- ifTrue: [ self storePointer: 3 ofObject: results withValue: trueObj ]
- ifFalse: [ self storePointer: 3 ofObject: results withValue: falseObj ].
- self storePointer: 4 ofObject: results
- withValue: (self integerObjectOf: fileSize).
- ^ results
- !

Item was changed:
  ----- Method: InterpreterSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize:posixPermissions:isSymlink: (in category 'file primitives') -----
  makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: posixPermissions posixPermissions: fileSize isSymlink: symlinkFlag
- <option: #PharoVM>
- <var: 'entryName' type: 'char *'>
 
+ ^(pluginList
+ detect: [:assoc| assoc key = 'FilePlugin']
+ ifNone: [self error: 'this message should not be sent unless the FilePlugin has been loaded']) value
+ makeDirEntryName: entryName size: entryNameSize
+ createDate: createDate modDate: modifiedDate
+ isDir: dirFlag fileSize: fileSize
+ posixPermissions: fileSize isSymlink: symlinkFlag!
- | modDateOop createDateOop nameString results |
-
- "allocate storage for results, remapping newly allocated
- oops in case GC happens during allocation"
- self pushRemappableOop:
- (self instantiateClass: (self splObj: ClassArray) indexableSize: 6).
- self pushRemappableOop:
- (self instantiateClass: (self splObj: ClassString) indexableSize: entryNameSize)..
- self pushRemappableOop: (self positive32BitIntegerFor: createDate).
- self pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).
-
- modDateOop   := self popRemappableOop.
- createDateOop := self popRemappableOop.
- nameString    := self popRemappableOop.
- results         := self popRemappableOop.
-
- 1 to: entryNameSize do: [ :i |
- self storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
- ].
-
- self storePointer: 0 ofObject: results withValue: nameString.
- self storePointer: 1 ofObject: results withValue: createDateOop.
- self storePointer: 2 ofObject: results withValue: modDateOop.
- dirFlag
- ifTrue: [ self storePointer: 3 ofObject: results withValue: trueObj ]
- ifFalse: [ self storePointer: 3 ofObject: results withValue: falseObj ].
- self storePointer: 4
- ofObject: results
- withValue: (self integerObjectOf: fileSize).
- self storePointer: 5
- ofObject: results
- withValue: (self integerObjectOf: posixPermissions).
- dirFlag
- ifTrue: [ self storePointer: 6 ofObject: results withValue: trueObj ]
- ifFalse: [ self storePointer: 6 ofObject: results withValue: falseObj ].
-
- ^ results
- !

Item was changed:
  ----- Method: MessageNode>>asTranslatorNodeIn: (in category '*VMMaker-C translation') -----
  asTranslatorNodeIn: aTMethod
  "make a CCodeGenerator equivalent of me"
  "selector is sometimes a Symbol, sometimes a SelectorNode!!
+ On top of this, numArgs is needed due to the (truly grody) use of
+ arguments as a place to store the extra expressions needed to generate
+ code for in-line to:by:do:, etc.  see below, where it is used.
+
+ Expand super nodes in place. Elide sends of halt so that halts can be
+ sprinkled through the simulator but will be eliminated from the generated C."
- On top of this, numArgs is needed due to the (truly grody) use of
- arguments as a place to store the extra expressions needed to generate
- code for in-line to:by:do:, etc.  see below, where it is used."
  | rcvrOrNil sel args ifNotNilBlock |
  rcvrOrNil := receiver ifNotNil: [receiver asTranslatorNodeIn: aTMethod].
  (rcvrOrNil notNil
  and: [rcvrOrNil isVariable
  and: [rcvrOrNil name = 'super']]) ifTrue:
  [^aTMethod superExpansionNodeFor: selector key args: arguments].
  sel := selector isSymbol ifTrue: [selector] ifFalse: [selector key].
+ sel == #halt ifTrue: [^receiver].
  (sel == #cCode:inSmalltalk: "extracting here rather than in translation allows inlining in the block."
   or: [sel == #cCode:]) ifTrue:
  [arguments first isBlockNode ifTrue:
  [| block |
  ^(block := arguments first asTranslatorNodeIn: aTMethod) statements size = 1
  ifTrue: [block statements first]
  ifFalse: [block]].
  (arguments first isLiteralNode
  and: [arguments first key isString
  and: [arguments first key isEmpty]]) ifTrue:
  [^arguments first asTranslatorNodeIn: aTMethod]].
  args := arguments
  select: [:arg| arg notNil]
  thenCollect: [:arg| arg asTranslatorNodeIn: aTMethod].
  (sel = #to:by:do: and: [arguments size = 7 and: [(arguments at: 7) notNil]]) ifTrue:
  ["Restore limit expr that got moved by transformToDo:"
  args := {(arguments at: 7) value asTranslatorNodeIn: aTMethod.
   args second.
   args third. "add the limit var as a hidden extra argument; we may need it later"
   TVariableNode new setName: arguments first key}].
  (sel == #ifTrue:ifFalse: and: [arguments first isJust: NodeNil]) ifTrue:
  [sel := #ifFalse:. args := {args last}].
  (sel == #ifTrue:ifFalse: and: [arguments last isJust: NodeNil]) ifTrue:
  [sel := #ifTrue:. args := {args first}].
  (sel == #ifFalse:ifTrue: and: [arguments first isJust: NodeNil]) ifTrue:
  [sel := #ifTrue:. args := {args last}].
  (sel == #ifFalse:ifTrue: and: [arguments last isJust: NodeNil]) ifTrue:
  [sel := #ifTrue:. args := {args first}].
  ((sel == #ifFalse: or: [sel == #or:])
  and: [arguments size = 2 and: [(arguments at: 2) notNil]]) ifTrue:
  ["Restore argument block that got moved by transformOr: or transformIfFalse:"
  args := {(arguments at: 2) asTranslatorNodeIn: aTMethod}].
  (args size > sel numArgs and: [sel ~~ #to:by:do:]) ifTrue: "to:by:do: has iLimiT hidden in last arg"
  ["prune the extra blocks left by ifTrue:, ifFalse:, and: & or:"
  self assert: args size - sel numArgs = 1.
  self assert: (args last isStmtList
   and: [args last statements size = 1
   and: [(args last statements first isVariable
  or: [args last statements first isConstant])
   and: [#('nil' true false) includes: args last statements first nameOrValue]]]).
  args := args first: sel numArgs].
  "For the benefit of later passes, e.g. value: inlining,
  transform e ifNotNil: [:v| ...] into  v := e. v ifNotNil: [...],
  which in fact means transforming (v := e) ifTrue: [:v|...] into v := e. v ifTrue: [...]."
  ((sel == #ifTrue: or: [sel == #ifFalse: or: [sel == #ifTrue:ifFalse: or: [sel == #ifFalse:ifTrue:]]])
  and: [receiver notNil
  and: [receiver isAssignmentEqualsEqualsNil
  and: [(ifNotNilBlock := args detect: [:arg| arg isStmtList and: [arg args size = 1]] ifNone: []) notNil]]]) ifTrue:
  [ifNotNilBlock setArguments: #().
  ^TStmtListNode new
  setArguments: #()
  statements:
  { receiver receiver asTranslatorNodeIn: aTMethod.
  TSendNode new
  setSelector: sel
  receiver: (TSendNode new
  setSelector: #==
  receiver: (receiver receiver variable asTranslatorNodeIn: aTMethod)
  arguments: {receiver arguments first asTranslatorNodeIn: aTMethod})
  arguments: args }].
  ^TSendNode new
  setSelector: sel
  receiver: rcvrOrNil
  arguments: args!

Item was removed:
- ----- Method: Spur32BitMMLECoSimulator>>return:restoringObjectsIn:savedHashes:and:savedHashes: (in category 'image segment in/out') -----
- return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes
- self leakCheckImageSegments ifTrue:
- [self halt: errCode printString].
- ^super return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes!

Item was added:
+ ----- Method: Spur32BitMMLECoSimulator>>return:restoringObjectsIn:upTo:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt: errCode printString].
+ ^super return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>mapOopsFrom:to:outPointers:outHashes: (in category 'image segment in/out') -----
+ mapOopsFrom: segStart to: segAddr outPointers: outPointerArray outHashes: savedOutHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt].
+ ^super mapOopsFrom: segStart to: segAddr outPointers: outPointerArray outHashes: savedOutHashes!

Item was removed:
- ----- Method: Spur32BitMMLESimulator>>return:restoringObjectsIn:savedHashes:and:savedHashes: (in category 'image segment in/out') -----
- return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes
- self leakCheckImageSegments ifTrue:
- [self halt: errCode printString].
- ^super return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes!

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>return:restoringObjectsIn:upTo:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt: errCode printString].
+ ^super return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was changed:
  ----- Method: Spur32BitMemoryManager>>addressAfter: (in category 'object enumeration') -----
  addressAfter: objOop
  "Answer the address immediately following an object."
+ <returnTypeC: #usqInt>
+ | numSlots |
+ numSlots := self rawNumSlotsOf: objOop.
+ numSlots = 0 ifTrue: [^objOop + self allocationUnit + self baseHeaderSize].
+ numSlots = self numSlotsMask ifTrue:
+ [numSlots := self rawOverflowSlotsOf: objOop].
+ ^objOop + self baseHeaderSize + (numSlots + (numSlots bitAnd: 1) << self shiftForWord)!
- | numSlots slotBytes |
- numSlots := self numSlotsOfAny: objOop.
- slotBytes := numSlots = 0
- ifTrue: [self allocationUnit]
- ifFalse: [numSlots + (numSlots bitAnd: 1) << self shiftForWord].
- ^objOop + self baseHeaderSize + slotBytes!

Item was changed:
  ----- Method: Spur32BitMemoryManager>>objectBytesForSlots: (in category 'object enumeration') -----
  objectBytesForSlots: numSlots
  "Answer the total number of bytes in an object with the given
  number of slots, including header and possible overflow size header."
  <returnTypeC: #usqInt>
+ ^numSlots = 0
+ ifTrue: [self allocationUnit + self baseHeaderSize] "always at least one slot for forwarding pointer"
+ ifFalse:
+ [numSlots + (numSlots bitAnd: 1) << self shiftForWord
+ + (numSlots >= self numSlotsMask
+ ifTrue: [self baseHeaderSize + self baseHeaderSize]
+ ifFalse: [self baseHeaderSize])]!
- ^(numSlots = 0
- ifTrue: [self allocationUnit] "always at least one slot for forwarding pointer"
- ifFalse: [numSlots + (numSlots bitAnd: 1) << self shiftForWord])
- + (numSlots >= self numSlotsMask
- ifTrue: [self baseHeaderSize + self baseHeaderSize]
- ifFalse: [self baseHeaderSize])!

Item was added:
+ ----- Method: Spur32BitMemoryManager>>savedOutHashFillValue (in category 'image segment in/out') -----
+ savedOutHashFillValue
+ <inline: true>
+ ^self maxIdentityHash + 1!

Item was added:
+ ----- Method: Spur32BitMemoryManager>>shorten:toIndexableSize: (in category 'allocation') -----
+ shorten: objOop toIndexableSize: indexableSize
+ "Reduce the number of indexable fields in objOop, a pointer object, to nSlots. Convert the
+ unused residual to a free chunk. Without changes to numSlotsForShortening:toIndexableSize:
+ this only works for arrayFormat and longFormat objects.
+ Answer the number of bytes returned to free memory, which may be zero if no change
+ was possible."
+ <inline: false>
+ | numSlots bytesBefore delta copy freeChunk |
+ self assert: (self oop: (self addressAfter: objOop) isLessThanOrEqualTo: endOfMemory).
+ numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize.
+ numSlots = (self numSlotsOf: objOop) ifTrue:
+ [^0].
+ bytesBefore := self bytesInObject: objOop.
+ delta := bytesBefore - (self objectBytesForSlots: numSlots).
+
+ (delta > 0
+ and: [delta <= self allocationUnit]) ifTrue:
+ [copy := self allocateSlots: numSlots
+ format: (self formatOf: objOop)
+ classIndex: (self classIndexOf: objOop).
+ copy ifNil: [self error: 'shorten:toIndexableSize: attempted to shorten to allocationUnit!!'].
+ 0 to: numSlots - 1 do:
+ [:i|
+ self storePointerUnchecked: i
+ ofObject: copy
+ withValue: (self fetchPointer: i ofObject: objOop)].
+ (self isRemembered: objOop) ifTrue:
+ [scavenger remember: copy].
+ self forward: objOop to: copy.
+ ^0].
+
+ (self hasOverflowHeader: objOop)
+ ifTrue:
+ [self rawOverflowSlotsOf: objOop put: numSlots.
+ numSlots < self numSlotsMask ifTrue:
+ [delta := delta - self allocationUnit]]
+ ifFalse:
+ [self assert: numSlots < self numSlotsMask.
+ self rawNumSlotsOf: objOop put: numSlots].
+
+ self assert: (self oop: (self addressAfter: objOop) + delta isLessThanOrEqualTo: endOfMemory).
+ "Since the 32-bit system rounds objects up to 64-bits, loosing
+ a slot may not actually change the bytes occupied by the object."
+ delta = 0 ifTrue:
+ [^0].
+
+ freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop).
+ self assert: (self addressAfter: freeChunk) <= endOfMemory.
+ (self isInOldSpace: objOop)
+ ifTrue:
+ [totalFreeOldSpace := totalFreeOldSpace + delta.
+ self addToFreeList: freeChunk bytes: delta]
+ ifFalse:
+ [self
+ setClassIndexOf: freeChunk to: self wordSizeClassIndexPun;
+ setFormatOf: freeChunk to: self firstLongFormat].
+ ^delta!

Item was removed:
- ----- Method: Spur64BitMMLECoSimulator>>return:restoringObjectsIn:savedHashes:and:savedHashes: (in category 'image segment in/out') -----
- return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes
- self leakCheckImageSegments ifTrue:
- [self halt: errCode printString].
- ^super return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes!

Item was added:
+ ----- Method: Spur64BitMMLECoSimulator>>return:restoringObjectsIn:upTo:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt: errCode printString].
+ ^super return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was added:
+ ----- Method: Spur64BitMMLESimulator>>mapOopsFrom:to:outPointers:outHashes: (in category 'image segment in/out') -----
+ mapOopsFrom: segStart to: segAddr outPointers: outPointerArray outHashes: savedOutHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt].
+ ^super mapOopsFrom: segStart to: segAddr outPointers: outPointerArray outHashes: savedOutHashes!

Item was removed:
- ----- Method: Spur64BitMMLESimulator>>return:restoringObjectsIn:savedHashes:and:savedHashes: (in category 'image segment in/out') -----
- return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes
- self leakCheckImageSegments ifTrue:
- [self halt: errCode printString].
- ^super return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes!

Item was added:
+ ----- Method: Spur64BitMMLESimulator>>return:restoringObjectsIn:upTo:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
+ self leakCheckImageSegments ifTrue:
+ [self halt: errCode printString].
+ ^super return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>addressAfter: (in category 'object enumeration') -----
  addressAfter: objOop
  "Answer the address immediately following an object."
+ <returnTypeC: #usqInt>
+ | numSlots |
+ numSlots := self rawNumSlotsOf: objOop.
+ numSlots = 0 ifTrue: [^objOop + self allocationUnit + self baseHeaderSize].
+ numSlots = self numSlotsMask ifTrue:
+ [numSlots := self rawOverflowSlotsOf: objOop].
+ ^objOop + self baseHeaderSize + (numSlots << self shiftForWord)!
- | numSlots slotBytes |
- numSlots := self numSlotsOfAny: objOop.
- slotBytes := numSlots = 0
- ifTrue: [self allocationUnit]
- ifFalse: [numSlots << self shiftForWord].
- ^objOop + self baseHeaderSize + slotBytes!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>objectBytesForSlots: (in category 'object enumeration') -----
  objectBytesForSlots: numSlots
  "Answer the total number of bytes in an object with the given
  number of slots, including header and possible overflow size header."
  <returnTypeC: #usqInt>
+ ^numSlots = 0
+ ifTrue: [self allocationUnit + self baseHeaderSize] "always at least one slot for forwarding pointer"
+ ifFalse:
+ [numSlots << self shiftForWord
+ + (numSlots >= self numSlotsMask
+ ifTrue: [self baseHeaderSize + self baseHeaderSize]
+ ifFalse: [self baseHeaderSize])]!
- ^(numSlots max: 1) << self shiftForWord
- + (numSlots >= self numSlotsMask
- ifTrue: [self baseHeaderSize + self baseHeaderSize]
- ifFalse: [self baseHeaderSize])!

Item was added:
+ ----- Method: Spur64BitMemoryManager>>savedOutHashFillValue (in category 'image segment in/out') -----
+ savedOutHashFillValue
+ <inline: true>
+ ^self maxIdentityHash + 1 << 32 + (self maxIdentityHash + 1)!

Item was added:
+ ----- Method: Spur64BitMemoryManager>>shorten:toIndexableSize: (in category 'allocation') -----
+ shorten: objOop toIndexableSize: indexableSize
+ "Reduce the number of indexable fields in objOop, a pointer object, to nSlots. Convert the
+ unused residual to a free chunk. Without changes to numSlotsForShortening:toIndexableSize:
+ this only works for arrayFormat and longFormat objects.
+ Answer the number of bytes returned to free memory, which may be zero if no change
+ was possible."
+ <inline: false>
+ | numSlots bytesBefore delta copy freeChunk |
+ numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize.
+ numSlots = (self numSlotsOf: objOop) ifTrue:
+ [^0].
+ bytesBefore := self bytesInObject: objOop.
+ delta := bytesBefore - (self objectBytesForSlots: numSlots).
+
+ self flag: 'this should update format for 32-bit indexable words; too lazy today.'.
+
+ delta = 0 ifTrue:
+ [^0].
+
+ delta <= self allocationUnit ifTrue:
+ [copy := self allocateSlots: numSlots
+ format: (self formatOf: objOop)
+ classIndex: (self classIndexOf: objOop).
+ copy ifNil: [self error: 'shorten:toIndexableSize: attempted to shorten to allocationUnit!!'].
+ 0 to: numSlots - 1 do:
+ [:i|
+ self storePointerUnchecked: i
+ ofObject: copy
+ withValue: (self fetchPointer: i ofObject: objOop)].
+ (self isRemembered: objOop) ifTrue:
+ [scavenger remember: copy].
+ self forward: objOop to: copy.
+ ^0].
+
+ (self hasOverflowHeader: objOop)
+ ifTrue:
+ [self rawOverflowSlotsOf: objOop put: numSlots.
+ numSlots < self numSlotsMask ifTrue:
+ [delta := delta - self allocationUnit]]
+ ifFalse:
+ [self assert: numSlots < self numSlotsMask.
+ self rawNumSlotsOf: objOop put: numSlots].
+
+ freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop).
+ self assert: (self addressAfter: freeChunk) <= endOfMemory.
+ (self isInOldSpace: objOop)
+ ifTrue:
+ [totalFreeOldSpace := totalFreeOldSpace + delta.
+ self addToFreeList: freeChunk bytes: delta]
+ ifFalse:
+ [self
+ setClassIndexOf: freeChunk to: self wordSizeClassIndexPun;
+ setFormatOf: freeChunk to: self firstLongFormat].
+ ^delta!

Item was changed:
  ----- Method: SpurMemoryManager>>assignClassIndicesAndPinFrom:to:outPointers:filling: (in category 'image segment in/out') -----
  assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray filling: loadedObjectsArray
  "This is part of loadImageSegmentFrom:outPointers:.
  Make a final pass, assigning the real class indices and/or pinning pinned objects."
  | fillIdx objOop |
  objOop := self objectStartingAt: segmentStart.
  fillIdx := 0.
  [objOop < segmentLimit] whileTrue:
  [| classRef classOop classIndex |
  self storePointerUnchecked: fillIdx ofObject: loadedObjectsArray withValue: objOop.
  fillIdx := fillIdx + 1.
  "In the segment, class indices are offset indexes into the segment data,
   or into outPointers.  See mapOopsFrom:to:outPointers:outHashes:."
+ classRef := self classIndexOf: objOop.
- classRef := (self classIndexOf: objOop) - self firstClassIndexPun.
  classOop := (classRef anyMask: TopHashBit)
+ ifTrue: [self fetchPointer: classRef - TopHashBit - self firstClassIndexPun ofObject: outPointerArray]
+ ifFalse: [classRef - self firstClassIndexPun * self allocationUnit + segmentStart].
- ifTrue: [self fetchPointer: classRef - TopHashBit ofObject: outPointerArray]
- ifFalse: [classRef * self allocationUnit + segmentStart].
  classIndex := self rawHashBitsOf: classOop.
  self assert: (classIndex > self lastClassIndexPun
   and: [(self classOrNilAtIndex: classIndex) = classOop]).
  self setClassIndexOf: objOop to: classIndex.
  ((self isInNewSpace: objOop)
   and: [self isPinned: objOop]) ifTrue:
  [| oldClone |
  oldClone := self cloneInOldSpaceForPinning: objOop.
  oldClone ~= 0 ifTrue:
  [self setIsPinnedOf: oldClone to: true.
  self forward: objOop to: oldClone]].
+ objOop := self objectAfter: objOop limit: segmentLimit]!
- objOop := self objectAfter: objOop limit: segmentLimit].
- !

Item was removed:
- ----- Method: SpurMemoryManager>>copyObj:toAddr:startAt:stopAt: (in category 'image segment in/out') -----
- copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg
- "This is part of storeImageSegmentInto:outPointers:roots:.
- Copy objOop into the segment beginning at segAddr, and forward it to the copy.
- If it is a class in the class table, set the copy's hash to 0 for reassignment on load,
- and mark it as a class by setting its isRemembered bit.
- Answer the next segmentAddr if successful.  Answer an appropriate error code if not"
-
- "Copy the object..."
- | bodySize copy hash newOop |
- <inline: false>
- bodySize := self bytesInObject: objOop.
- (self oop: segAddr + bodySize isGreaterThanOrEqualTo: endSeg) ifTrue:
- [^PrimErrWritePastObject].
- self mem: segAddr asVoidPointer cp: (self startOfObject: objOop) asVoidPointer y: bodySize.
- copy := self objectStartingAt: segAddr.
-
- "Clear remembered, mark bits of all headers copied into the segment (except classes)"
- self
- setIsRememberedOf: copy to: false;
- setIsMarkedOf: copy to: false.
-
- self ifAProxy: objOop updateCopy: copy.
-
- "If the object is a class, zero its identityHash (which is its classIndex) and set its
- isRemembered bit.  It will be assigned a new hash and entered into the table on load."
- hash := self rawHashBitsOf: objOop.
- (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop]) ifTrue:
- [self setHashBitsOf: copy to: 0.
- self setIsRememberedOf: copy to: true].
-
- newOop := copy - segStart / self allocationUnit.
- newOop > self maxIdentityHash ifTrue:
- [^PrimErrLimitExceeded].
- self setHashBitsOf: objOop to: copy - segStart / self allocationUnit.
- self setIsMarkedOf: objOop to: true.
-
- "Answer the new end of segment"
- ^segAddr + bodySize!

Item was added:
+ ----- Method: SpurMemoryManager>>copyObj:toAddr:startAt:stopAt:savedFirstFields:index: (in category 'image segment in/out') -----
+ copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg savedFirstFields: savedFirstFields index: i
+ "This is part of storeImageSegmentInto:outPointers:roots:.
+ Copy objOop into the segment beginning at segAddr, and forward it to the copy,
+ saving its first field in savedFirstField, and setting its marked bit to indicate it has
+ been copied.  If it is a class in the class table, set the copy's hash to 0 for reassignment
+ on load, and mark it as a class by setting its isRemembered bit.
+ Answer the next segmentAddr if successful.  Answer an appropriate error code if not"
+
+ "Copy the object..."
+ | bodySize copy hash |
+ <inline: false>
+ bodySize := self bytesInObject: objOop.
+ (self oop: segAddr + bodySize isGreaterThanOrEqualTo: endSeg) ifTrue:
+ [^PrimErrWritePastObject].
+ self mem: segAddr asVoidPointer cp: (self startOfObject: objOop) asVoidPointer y: bodySize.
+ copy := self objectStartingAt: segAddr.
+
+ "Clear remembered, mark bits of all headers copied into the segment (except classes)"
+ self
+ setIsRememberedOf: copy to: false;
+ setIsMarkedOf: copy to: false.
+
+ "Make any objects with hidden dynamic state (contexts, methods) look like normal objects."
+ self ifAProxy: objOop updateCopy: copy.
+
+ "If the object is a class, zero its identityHash (which is its classIndex) and set its
+ isRemembered bit.  It will be assigned a new hash and entered into the table on load."
+ hash := self rawHashBitsOf: objOop.
+ (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop]) ifTrue:
+ [self setHashBitsOf: copy to: 0.
+ self setIsRememberedOf: copy to: true].
+
+ "Now forward the object to its copy in the segment."
+ self storePointerUnchecked: i ofObject: savedFirstFields withValue: (self fetchPointer: 0 ofObject: objOop);
+ storePointerUnchecked: 0 ofObject: objOop withValue: copy;
+ setIsMarkedOf: objOop to: true.
+
+ "Answer the new end of segment"
+ ^segAddr + bodySize!

Item was changed:
  ----- Method: SpurMemoryManager>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
  loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
+ "This primitive is called from Smalltalk as...
- "This primitive is called from Squeak as...
  <imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
 
  "This primitive will load a binary image segment created by primitiveStoreImageSegment.
  It expects the outPointer array to be of the proper size, and the wordArray to be well formed.
  It will return as its value the original array of roots, and the segmentWordArray will become an
  array of the loaded objects.  If this primitive should fail, the segmentWordArray will, sadly, have
  been reduced to an unrecognizable and unusable jumble.  But what more could you have done
+ with it anyway?
- with it anyway?"
 
+ The primitive, if it succeeds, also becomes the segmentWordArray into the array of loaded objects.
+ This allows fixing up of loaded objects directly, without nextObject, which Spur doesn't support."
+
  <inline: false>
  | segmentLimit segmentStart segVersion errorCode numLoadedObjects loadedObjectsArray |
 
  segmentLimit := self numSlotsOf: segmentWordArray.
  (self objectBytesForSlots: segmentLimit) < (self allocationUnit "version info" + self baseHeaderSize "one object header") ifTrue:
  [^PrimErrBadArgument].
 
  "Verify format.  If the format is wrong, word-swap (since ImageSegment data are 32-bit longs).
  If it is still wrong, undo the damage and fail."
  segVersion := self longAt: segmentWordArray + self baseHeaderSize.
  (coInterpreter readableFormat: (segVersion bitAnd: 16rFFFFFF "low 3 bytes")) ifFalse:
  [self reverseBytesIn32BitWordsFrom: segmentWordArray + self baseHeaderSize
  to: (self addressAfter: segmentWordArray).
  segVersion := self longAt: segmentWordArray + self baseHeaderSize.
  (coInterpreter readableFormat: (segVersion bitAnd: 16rFFFFFF "low 3 bytes")) ifFalse:
  [self reverseBytesIn32BitWordsFrom: segmentWordArray + self baseHeaderSize
  to: (self addressAfter: segmentWordArray).
  ^PrimErrBadArgument]].
 
  segmentStart := segmentWordArray + self baseHeaderSize + self allocationUnit.
  segmentLimit := segmentLimit * self bytesPerOop + segmentWordArray + self baseHeaderSize.
 
  "Notionally reverse the Byte type objects if the data is from opposite endian machine.
  Test top byte.  $d on the Mac or $s on the PC.  Rest of word is equal.  If Spur is ever
  ported to big-endian machines then the segment may have to be byte/word swapped,
  but so far it only runs on little-endian machines, so for now just fail if endinanness is wrong."
  self flag: #endianness.
  (segVersion >> 24 bitAnd: 16rFF) ~= (self imageSegmentVersion >> 24 bitAnd: 16rFF) ifTrue:
  "Reverse the byte-type objects once"
  [true
  ifTrue: [^PrimErrBadArgument]
  ifFalse:
  [self byteSwapByteObjectsFrom: (self objectStartingAt: segmentStart)
  to: segmentLimit
  flipFloatsIf: false]].
 
  "scan through mapping oops and validating class references. Defer entering any
  class objects into the class table and/or pinning objects until a second pass."
  errorCode := self mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray.
  errorCode > 0 ifTrue:
  [^errorCode].
  numLoadedObjects := errorCode negated.
  loadedObjectsArray := self allocateSlots: numLoadedObjects format: self arrayFormat classIndex: ClassArrayCompactIndex.
  loadedObjectsArray ifNil:
  [^PrimErrNoMemory].
 
  "Scan for classes contained in the segment, entering them into the class table.
  Classes are at the front, after the root array and have the remembered bit set."
  errorCode := self enterClassesIntoClassTableFrom: segmentStart to: segmentLimit.
  errorCode ~= 0 ifTrue:
  [^errorCode].
 
  "Make a final pass, assigning class indices and/or pinning pinned objects and collecting the loaded objects in loadedObjectsArray"
  self assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray filling: loadedObjectsArray.
 
  "Evaporate the container, leaving the newly loaded objects in place."
  (self hasOverflowHeader: segmentWordArray)
  ifTrue: [self rawOverflowSlotsOf: segmentWordArray put: self allocationUnit / self bytesPerOop]
  ifFalse: [self rawNumSlotsOf: segmentWordArray put: self allocationUnit / self bytesPerOop].
 
  "Finally forward the segmentWordArray to the loadedObjectsArray"
  self forward: segmentWordArray to: loadedObjectsArray.
 
  self runLeakCheckerFor: GCModeImageSegment.
 
  ^self objectStartingAt: segmentStart!

Item was changed:
  ----- Method: SpurMemoryManager>>mapOopsAndValidateClassRefsFrom:to:outPointers: (in category 'image segment in/out') -----
  mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray
  "This is part of loadImageSegmentFrom:outPointers:.
  Scan through mapping oops and validating class references.  Defer
  entering any class objects into the class table and/or pinning objects
  until the second pass in assignClassIndicesAndPinFrom:to:outPointers:."
  | numOutPointers numSegObjs objOop |
  numOutPointers := self numSlotsOf: outPointerArray.
  numSegObjs := 0.
  objOop := self objectStartingAt: segmentStart.
  [objOop < segmentLimit] whileTrue:
  [| classIndex hash oop mappedOop |
  numSegObjs := numSegObjs + 1.
  (self isMarked: objOop) ifTrue:
  [^PrimErrInappropriate].
+ classIndex := self classIndexOf: objOop.
- classIndex := (self classIndexOf: objOop) - self firstClassIndexPun.
  "validate the class ref, but don't update it until any internal classes have been added to the class table."
  (classIndex anyMask: TopHashBit)
  ifTrue:
+ [classIndex := classIndex - TopHashBit - self firstClassIndexPun.
+ classIndex >= numOutPointers ifTrue:
+ [^PrimErrBadIndex halt].
+ mappedOop := self fetchPointer: classIndex ofObject: outPointerArray.
- [classIndex - TopHashBit >= numOutPointers ifTrue:
- [^PrimErrBadIndex].
- mappedOop := self fetchPointer: classIndex - TopHashBit ofObject: outPointerArray.
  hash := self rawHashBitsOf: mappedOop.
  (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = mappedOop]) ifFalse:
+ [^PrimErrInappropriate halt]]
- [^PrimErrInappropriate]]
  ifFalse: "The class is contained within the segment."
+ [(oop := classIndex - self firstClassIndexPun * self allocationUnit + segmentStart) >= segmentLimit ifTrue:
+ [^PrimErrBadIndex halt].
- [(oop := classIndex * self allocationUnit + segmentStart) >= segmentLimit ifTrue:
- [^PrimErrBadIndex].
  (self rawHashBitsOf: oop) ~= 0 ifTrue:
+ [^PrimErrInappropriate halt]].
- [^PrimErrInappropriate]].
  0 to: (self numPointerSlotsOf: objOop) - 1 do:
  [:i|
  oop := self fetchPointer: i ofObject: objOop.
  (self isNonImmediate: oop) ifTrue:
  [(oop anyMask: TopOopBit)
  ifTrue:
  [(oop := oop - TopOopBit / self bytesPerOop) >= numOutPointers ifTrue:
+ [^PrimErrBadIndex halt].
- [^PrimErrBadIndex].
  mappedOop := self fetchPointer: oop ofObject: outPointerArray]
  ifFalse:
  [(oop bitAnd: self allocationUnit - 1) ~= 0 ifTrue:
+ [^PrimErrInappropriate halt].
- [^PrimErrInappropriate].
  (mappedOop := oop + segmentStart) >= segmentLimit ifTrue:
+ [^PrimErrBadIndex halt]].
- [^PrimErrBadIndex]].
  self storePointerUnchecked: i ofObject: objOop withValue: mappedOop]].
  objOop := self objectAfter: objOop limit: segmentLimit].
  ^numSegObjs negated!

Item was changed:
  ----- Method: SpurMemoryManager>>mapOopsFrom:to:outPointers:outHashes: (in category 'image segment in/out') -----
  mapOopsFrom: segStart to: segAddr outPointers: outPointerArray outHashes: savedOutHashes
  "This is part of storeImageSegmentInto:outPointers:roots:.
  Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
+ have had their first fields set to point to their copies in segmentWordArray.  Answer
+ the outIndex if the scan succeded.  Fail if outPointers is too small and answer -1.
+
+ As established by copyObj:toAddr:startAt:stopAt:savedFirstFields:index:,
+ the marked bit is set for all objects in the segment
+ the remembered bit is set for all classes in the segment.
+
+ Class indices should be set as follows (see assignClassIndicesAndPinFrom:to:outPointers:filling:)
+ - class indices for classes in the segment "
- have had their hashes set to point to their copies in segmentWordArray.  Answer the
- outIndex if the scan succeded.  Fail if outPointers is too small and answer -1."
  | objOop outIndex |
  outIndex := 0.
  self fillObj: outPointerArray numSlots: (self numSlotsOf: outPointerArray) with: nilObj.
  objOop := self objectStartingAt: segStart.
  [objOop < segAddr] whileTrue:
+ [| oop hash segIndex |
- [| oop segIndex |
  oop := self fetchClassOfNonImm: objOop.
+ "Set the classIndex of the instance.  This is a segment offset (segAddr - segStart / allocatiopnUnit) for instances of
+  classes within the segment, and an outPointer index (index in outPointers + TopHashBit) for classes outside the segment."
+ (self isMarked: oop)
+ ifTrue: "oop is a class in the segment; storeImageSegmentInto:outPointers:roots: established offset is within range."
+ [oop := self fetchPointer: 0 ofObject: oop.
+ self assert: (self oop: oop isGreaterThanOrEqualTo: segStart andLessThan: segAddr).
+ segIndex := oop - segStart / self allocationUnit.
+ self deny: (segIndex + self firstClassIndexPun anyMask: TopHashBit)]
+ ifFalse: "oop is an outPointer; locate or allocate its oop"
+ [hash := self rawHashBitsOf: oop.
+ ((hash anyMask: TopHashBit)
+ and: [hash - TopHashBit <= outIndex
+ and: [oop = (self fetchPointer: hash - TopHashBit ofObject: outPointerArray)]])
+ ifTrue: [segIndex := hash]
+ ifFalse: "oop is a new outPointer; allocate its oop"
+ [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes.
+ outIndex = 0 ifTrue: "no room in outPointers; fail"
+ [^-1].
+ self assert: ((self rawHashBitsOf: oop) anyMask: TopHashBit).
+ segIndex := self rawHashBitsOf: oop]].
- (self isMarked: oop) ifFalse: "oop is a new outPointer; allocate its oop"
- [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes.
- outIndex = 0 ifTrue:"no room in outPointers; fail"
- [^-1]].
- "Set the clone's class index to an offset index into segmentWordArray.
-  Use an offset so that code cannot confuse a clone with e.g. a forwarder."
- segIndex := self rawHashBitsOf: oop.
  self setClassIndexOf: objOop to: segIndex + self firstClassIndexPun.
  0 to: (self numPointerSlotsOf: objOop) - 1 do:
  [:i|
  oop := self fetchPointer: i ofObject: objOop.
  (self isNonImmediate: oop) ifTrue:
+ [(self isMarked: oop)
+ ifTrue: "oop is an object in the segment."
+ [oop := self fetchPointer: 0 ofObject: oop.
+ self assert: (self oop: oop isGreaterThanOrEqualTo: segStart andLessThan: segAddr).
+ oop := oop - segStart]
+ ifFalse: "oop is an outPointer; locate or allocate its oop"
+ [hash := self rawHashBitsOf: oop.
+ ((hash anyMask: TopHashBit)
+ and: [(hash := hash - TopHashBit) <= outIndex
+ and: [oop = (self fetchPointer: hash ofObject: outPointerArray)]])
+ ifTrue: [oop := hash * self bytesPerOop + TopOopBit]
+ ifFalse: "oop is a new outPointer; allocate its oop"
+ [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes.
+ outIndex = 0 ifTrue: "no room in outPointers; fail"
+ [^-1].
+ self assert: ((self rawHashBitsOf: oop) anyMask: TopHashBit).
+ oop := (self rawHashBitsOf: objOop) - TopHashBit * self bytesPerOop + TopOopBit]].
- [(self isMarked: oop) ifFalse: "oop is a new outPointer; allocate its oop"
- [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes.
- outIndex = 0 ifTrue: "no room in outPointers; fail"
- [^-1]].
- oop := self mappedInSegmentOopOf: oop.
  self storePointerUnchecked: i ofObject: objOop withValue: oop]].
  objOop := self objectAfter: objOop limit: segAddr].
  ^outIndex!

Item was removed:
- ----- Method: SpurMemoryManager>>mappedInSegmentOopOf: (in category 'image segment in/out') -----
- mappedInSegmentOopOf: objOop
- "This is part of storeImageSegmentInto:outPointers:roots:.
- objOop is an object whose hash has been set to its mapped oop in either the segment or the
- out pointers.  If its hash's top bit is set then it is in out pointers.  Answer the mapped oop."
- <inline: true>
- | hash |
- hash := self rawHashBitsOf: objOop.
- ^(hash anyMask: TopHashBit)
- ifTrue: [hash - TopHashBit * self bytesPerOop + TopOopBit]
- ifFalse: [hash * self allocationUnit]!

Item was changed:
  ----- Method: SpurMemoryManager>>moveClassesForwardsIn: (in category 'image segment in/out') -----
  moveClassesForwardsIn: arrayOfObjects
  "This is part of storeImageSegmentInto:outPointers:roots:.
  Both to expand the max size of segment and to reduce the length of the
  load-time pass that adds classes to the class table, move classes to the
+ front of arrayOfObjects, leaving the root array as the first element.
+ Answer the number of classes in the segment."
+ | nClasses there |
+ nClasses := there := 0. "if > 0, this is the index of the first non-class past the first element."
- front of arrayOfObjects, leaving the root array as the first element."
- | there |
- there := 0. "if > 0, this is the index of the first non-class past the first element."
  1 to: (self numSlotsOf: arrayOfObjects) - 1 do:
  [:here| | objOop hash tempObjOop |
  objOop := self fetchPointer: here ofObject: arrayOfObjects.
  hash := self rawHashBitsOf: objOop.
  (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop])
  ifTrue:
+ [nClasses := nClasses + 1.
+ there > 0 ifTrue: "if there is zero we're in a run of classes at the start so don't move"
- [there > 0 ifTrue: "if there is zero we're in a run of classes at the start so don't move"
  [tempObjOop := self fetchPointer: there ofObject: arrayOfObjects.
  self storePointerUnchecked: there ofObject: arrayOfObjects withValue: objOop.
  self storePointerUnchecked: here ofObject: arrayOfObjects withValue: tempObjOop.
  there := there + 1]]
  ifFalse:
  [there = 0 ifTrue:
+ [there := here]]].
+ ^nClasses!
- [there := here]]]!

Item was changed:
  ----- Method: SpurMemoryManager>>newOutPointer:at:in:hashes: (in category 'image segment in/out') -----
  newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes
  "This is part of storeImageSegmentInto:outPointers:roots:.
  oop is a new outPointer; allocate its oop, and answer the new outIndex.
  If outPointerArray is full, answer 0."
  <inline: true>
  outIndex >= (self numSlotsOf: outPointerArray) ifTrue:
  ["no room in outPointers; fail"
  ^0].
  self storePointer: outIndex ofObject: outPointerArray withValue: oop.
  self storeLong32: outIndex ofObject: savedOutHashes withValue: (self rawHashBitsOf: oop).
  self setHashBitsOf: oop to: outIndex + TopHashBit.
- self setIsMarkedOf: oop to: true.
  ^outIndex + 1!

Item was changed:
  ----- Method: SpurMemoryManager>>noCheckPush:onObjStack: (in category 'obj stacks') -----
  noCheckPush: objOop onObjStack: objStack
+ <inline: false>
  "Push an element on an objStack.  Split from push:onObjStack: for testing."
  | topx |
  self eassert: [self isValidObjStack: objStack].
  self cCode: '' "for debugging markAndTrace: set (MarkStackRecord := OrderedCollection new)"
  inSmalltalk:
  [MarkStackRecord ifNotNil:
  [(self fetchPointer: ObjStackMyx ofObject: objStack) = MarkStackRootIndex ifTrue:
  [MarkStackRecord addLast: {#push. objOop}]]].
  topx := self fetchPointer: ObjStackTopx ofObject: objStack.
  topx >= ObjStackLimit
  ifTrue:
  [self noCheckPush: objOop
  onObjStack: (self ensureRoomOnObjStackAt: (self fetchPointer: ObjStackMyx ofObject: objStack))]
  ifFalse:
  [self storePointer: ObjStackFixedSlots + topx ofObjStack: objStack withValue: objOop.
  self storePointer: ObjStackTopx ofObjStack: objStack withValue: topx + 1].
  ^objOop!

Item was changed:
  ----- Method: SpurMemoryManager>>objectsReachableFromRoots: (in category 'image segment in/out') -----
  objectsReachableFromRoots: arrayOfRoots
  "This is part of storeImageSegmentInto:outPointers:roots:.
  Answer an Array of all the objects only reachable from the argument, an Array of root objects,
  starting with arrayOfRoots.  If there is no space, answer a SmallInteger whose value is the
  number of slots required.  This is used to collect the objects to include in an image segment
  on Spur, separate from creating the segment, hence simplifying the implementation.
  Thanks to Igor Stasenko for this idea."
 
  | freeChunk ptr start limit count oop objOop |
  self assert: (self isArray: arrayOfRoots).
  "Mark all objects except those only reachable from the arrayOfRoots by marking
  each object in arrayOfRoots and then marking all reachable objects (from the
  system roots).  This leaves unmarked only objects reachable from the arrayOfRoots.
  N.B. A side-effect of the marking is that all forwarders in arrayOfRoots will be followed."
    self assert: self allObjectsUnmarked.
  self markObjectsIn: arrayOfRoots.
  self markObjects: false.
 
  "After the mark phase all unreachable weak slots will have been nilled
  and all active ephemerons fired."
  self assert: (self isEmptyObjStack: markStack).
  self assert: (self isEmptyObjStack: weaklingStack).
  self assert: self noUnscannedEphemerons.
 
  "Use the largest free chunk to answer the result."
  freeChunk := self allocateLargestFreeChunk.
  ptr := start := freeChunk + self baseHeaderSize.
  limit := self addressAfter: freeChunk.
  count := 0.
 
  "First put the arrayOfRoots; order is important."
  count := count + 1.
  ptr < limit ifTrue:
  [self longAt: ptr put: arrayOfRoots.
  ptr := ptr + self bytesPerOop].
 
  0 to: (self numSlotsOf: arrayOfRoots) - 1 do:
  [:i|
  oop := self fetchPointer: i ofObject: arrayOfRoots.
  (self isNonImmediate: oop) ifTrue:
+ [self noCheckPush: oop onObjStack: markStack]].
- [self push: oop onObjStack: markStack]].
 
  "Now collect the unmarked objects reachable from the roots."
  [self isEmptyObjStack: markStack] whileFalse:
  [objOop := self popObjStack: markStack.
  count := count + 1.
  ptr < limit ifTrue:
  [self longAt: ptr put: objOop.
  ptr := ptr + self bytesPerOop].
  oop := self fetchClassOfNonImm: objOop.
  (self isMarked: oop) ifFalse:
  [self setIsMarkedOf: objOop to: true.
+ self noCheckPush: oop onObjStack: markStack].
- self push: oop onObjStack: markStack].
  ((self isContextNonImm: objOop)
   and: [coInterpreter isStillMarriedContext: objOop]) "widow now, before the loop"
  ifTrue:
  [0 to: (coInterpreter numSlotsOfMarriedContext: objOop) - 1 do:
  [:i|
  oop := coInterpreter fetchPointer: i ofMarriedContext: objOop.
  ((self isImmediate: oop)
   or: [self isMarked: oop]) ifFalse:
  [self setIsMarkedOf: objOop to: true.
+ self noCheckPush: oop onObjStack: markStack]]]
- self push: oop onObjStack: markStack]]]
  ifFalse:
  [0 to: (self numPointerSlotsOf: objOop) - 1 do:
  [:i|
  oop := self fetchPointer: i ofObject: objOop.
  ((self isImmediate: oop)
   or: [self isMarked: oop]) ifFalse:
  [self setIsMarkedOf: objOop to: true.
+ self noCheckPush: oop onObjStack: markStack]]]].
- self push: oop onObjStack: markStack]]]].
 
  self unmarkAllObjects.
 
  totalFreeOldSpace := totalFreeOldSpace - (self bytesInObject: freeChunk).
  "Now try and allocate the result"
  (count > (ptr - start / self bytesPerOop) "not enough room"
  or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
  [self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
  self checkFreeSpace: GCModeImageSegment.
  ^self integerObjectOf: count].
  "There's room; set the format, & classIndex and shorten."
  self setFormatOf: freeChunk to: self arrayFormat.
  self setClassIndexOf: freeChunk to: ClassArrayCompactIndex.
  self shorten: freeChunk toIndexableSize: count.
+ (self isForwarded: freeChunk) ifTrue:
+ [freeChunk := self followForwarded: freeChunk].
  self possibleRootStoreInto: freeChunk.
  self checkFreeSpace: GCModeImageSegment.
  self runLeakCheckerFor: GCModeImageSegment.
  ^freeChunk!

Item was changed:
  ----- Method: SpurMemoryManager>>push:onObjStack: (in category 'obj stacks') -----
  push: objOop onObjStack: objStack
+ <inline: true>
  self assert: (self addressCouldBeOop: objOop).
  (self isImmediate: objOop)
  ifTrue:
  [self assert: objStack = markStack.
  self assert: (self addressCouldBeObj: (self topOfObjStack:
  (0 = (self fetchPointer: ObjStackTopx ofObject: objStack)
  ifTrue: [self fetchPointer: ObjStackNextx ofObject: objStack]
  ifFalse: [objStack])))]
  ifFalse: "There should be no weaklings on the mark stack."
  [self assert: (objStack = markStack and: [self isWeakNonImm: objOop]) not.
  "There should only be weaklings on the weaklingStack"
  self assert: (objStack ~= weaklingStack or: [self isWeakNonImm: objOop])].
  ^self noCheckPush: objOop onObjStack: objStack!

Item was changed:
  ----- Method: SpurMemoryManager>>restoreObjectsIn:savedHashes: (in category 'image segment in/out') -----
  restoreObjectsIn: objArray savedHashes: savedHashes
  "This is part of storeImageSegmentInto:outPointers:roots:.
  Enumerate the objects in objArray, unmarking them and restoring their hashes
  from the corresponding 32-bit slots in savedHashes.  The first unused entry in
  objArray will have a non-hash value entry in savedHashes.  Free savedHashes."
+ <inline: true>
- <inline: false>
  0 to: (self numSlotsOf: objArray) - 1 do:
  [:i| | hash oop |
  (hash := self fetchLong32: i ofObject: savedHashes) > self maxIdentityHash ifTrue:
  [(self isInOldSpace: savedHashes) ifTrue:
  [self freeObject: savedHashes].
  ^self].
  oop := self fetchPointer: i ofObject: objArray.
  self setHashBitsOf: oop to: hash.
  self setIsMarkedOf: oop to: false].
  (self isInOldSpace: savedHashes) ifTrue:
  [self freeObject: savedHashes]!

Item was added:
+ ----- Method: SpurMemoryManager>>restoreObjectsIn:upTo:savedFirstFields: (in category 'image segment in/out') -----
+ restoreObjectsIn: objArray upTo: limitOrTag savedFirstFields: savedFirstFields
+ "This is part of storeImageSegmentInto:outPointers:roots:.
+ Enumerate the objects in objArray, unmarking them and restoring their saved first fields
+ from the corresponding slot in savedFirstFields.  The first unused entry in
+ objArray will have a non-hash value entry in savedHashes.  Free savedFirstFields."
+ <inline: true>
+ | numSlots |
+ numSlots := limitOrTag = -1 ifTrue: [self numSlotsOf: objArray] ifFalse: [limitOrTag].
+ 0 to: numSlots - 1 do:
+ [:i| | oop |
+ oop := self fetchPointer: i ofObject: objArray.
+ self storePointerUnchecked: 0 ofObject: oop withValue: (self fetchPointer: i ofObject: savedFirstFields).
+ self setIsMarkedOf: oop to: false].
+ (self isInOldSpace: savedFirstFields) ifTrue:
+ [self freeObject: savedFirstFields]!

Item was removed:
- ----- Method: SpurMemoryManager>>return:restoringObjectsIn:savedHashes:and:savedHashes: (in category 'image segment in/out') -----
- return: errCode restoringObjectsIn: firstArray savedHashes: firstSavedHashes and: secondArray savedHashes: secondSavedHashes
- "This is part of storeImageSegmentInto:outPointers:roots:."
- self restoreObjectsIn: firstArray savedHashes: firstSavedHashes.
- self restoreObjectsIn: secondArray savedHashes: secondSavedHashes.
- self runLeakCheckerFor: GCModeImageSegment.
- self assert: self allObjectsUnmarked.
- ^errCode!

Item was added:
+ ----- Method: SpurMemoryManager>>return:restoringObjectsIn:upTo:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
+ return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields and: secondArray savedHashes: secondSavedHashes
+ "This is part of storeImageSegmentInto:outPointers:roots:."
+ self restoreObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields.
+ self restoreObjectsIn: secondArray savedHashes: secondSavedHashes.
+ self runLeakCheckerFor: GCModeImageSegment.
+ self assert: self allObjectsUnmarked.
+ ^errCode!

Item was changed:
  ----- Method: SpurMemoryManager>>shorten:toIndexableSize: (in category 'allocation') -----
  shorten: objOop toIndexableSize: indexableSize
  "Reduce the number of indexable fields in objOop, a pointer object, to nSlots. Convert the
  unused residual to a free chunk. Without changes to numSlotsForShortening:toIndexableSize:
  this only works for arrayFormat and longFormat objects.
+ Answer the number of bytes returned to free memory, which may be zero if no change was possible."
+ self subclassResponsibility!
- Answer the number of bytes returned to free memory, which may be zero if no change
- was possible."
- <inline: false>
- | numSlots bytesBefore delta freeChunk |
- numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize.
- numSlots = (self numSlotsOf: objOop) ifTrue:
- [^0].
- bytesBefore := self bytesInObject: objOop.
- (self hasOverflowHeader: objOop)
- ifTrue: [self rawOverflowSlotsOf: objOop put: numSlots]
- ifFalse:
- [self assert: numSlots < self numSlotsMask.
- self rawNumSlotsOf: objOop put: numSlots].
- delta := bytesBefore - (self bytesInObject: objOop).
- "We have options.
- 1. we can clone the object and forward to the clone.
- 2. if the following object has a short header we can given it a large header."
- self flag: 'deal with it, dude'.
- delta <= self allocationUnit ifTrue:
- [self error: 'shorten:toIndexableSize: attempted to shorten to allocationUnit!!'].
- freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop).
- (self isInOldSpace: objOop)
- ifTrue:
- [totalFreeOldSpace := totalFreeOldSpace + delta.
- self addToFreeList: freeChunk bytes: delta]
- ifFalse:
- [self
- setClassIndexOf: freeChunk to: self wordSizeClassIndexPun;
- setFormatOf: freeChunk to: self firstLongFormat].
- ^delta!

Item was changed:
  ----- Method: SpurMemoryManager>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
+ storeImageSegmentInto: segmentWordArrayArg outPointers: outPointerArrayArg roots: arrayOfRootsArg
- storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
  "This primitive is called from Squeak as...
  <imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray.
 
+ This primitive will store a binary image segment (in the same format as objects in the heap) of the
- This primitive will store a binary image segment (in the same format as objercts in the heap) of the
  set of objects in arrayOfObjects.  All pointers from within the set to objects outside the set will be
  copied into the array of outPointers.  In their place in the image segment will be an oop equal to the
+ offset in the outPointer array (the first would be 8), but with the high bit set.
- offset in the outPointer array (the first would be 4). but with the high bit set.
 
+ Since Spur has a class table the load primitive must insert classes that have instances into the
+ class table.  This primitive marks such classes using the isRemembered bit, which isn't meaningful
+ as a remembered bit in the segment.
- Since Spur has a class table the load primitive must insert classes that have instances in the class
- table.  This primitive marks such classes using the isRemembered bit, which isn't meaningful as a
- remembered bit in the segment.
 
  The primitive expects the segmentWordArray and outPointerArray to be more than adequately long.
  In this case it returns normally, and truncates the two arrays to exactly the right size.
 
  The primitive can fail for the following reasons with the specified failure codes:
+ PrimErrGenericError: the segmentWordArray is too small for the version stamp
+ PrimErrWritePastObject: the segmentWordArray is too small to contain the reachable objects
- PrimErrWritePastObject: the segmentWordArray is too small
  PrimErrBadIndex: the outPointerArray is too small
  PrimErrNoMemory: additional allocations failed
+ PrimErrLimitExceeded: there is no room in the hash field to store out pointer indices or class references."
- PrimErrLimitExceeded: there is no room in the hash field to store object oops."
  <inline: false>
+ | segmentWordArray outPointerArray arrayOfRoots
+  arrayOfObjects savedFirstFields savedOutHashes segStart segAddr endSeg outIndex numClassesInSegment |
+ ((self isObjImmutable: segmentWordArrayArg)
+ or: [self isObjImmutable: outPointerArrayArg]) ifTrue:
+ [^PrimErrNoModification].
+ "Since segmentWordArrayArg & outPointerArrayArg may get shortened, they can't be pinned."
+ ((self isPinned: segmentWordArrayArg)
+ or: [self isPinned: outPointerArrayArg]) ifTrue:
+ [^PrimErrObjectIsPinned].
+ (self numSlotsOf: outPointerArrayArg) > self maxIdentityHash ifTrue:
+ [^PrimErrLimitExceeded].
- | arrayOfObjects savedInHashes savedOutHashes fillValue segStart segAddr endSeg outIndex |
 
  self runLeakCheckerFor: GCModeImageSegment.
 
+ "First scavenge to coillect any new space garbage that refers to the graph."
+ self scavengingGC.
+ segmentWordArray := self updatePostScavenge: segmentWordArrayArg.
+ outPointerArray := self updatePostScavenge: outPointerArrayArg.
+ arrayOfRoots := self updatePostScavenge: arrayOfRootsArg.
+
+ "Now compute the transitive closure, collecting the sequence of objects to be stored in the arrayOfObjects array.
+ Included in arrayOfObjects are the arrayOfRoots and all its contents.  All objects have been unmarked."
- "First compute the transitive closure, collecting the sequence of objects to be stored in the arrayOfObjects array."
  arrayOfObjects := self objectsReachableFromRoots: arrayOfRoots.
  arrayOfObjects ifNil:
  [^PrimErrNoMemory].
 
  self assert: self allObjectsUnmarked. "work to be done when the incremental GC is written"
 
+ "Both to expand the max size of segment and to reduce the length of the
+ load-time pass that adds classes to the class table, move classes to the
+ front of arrayOfObjects, leaving the root array as the first element."
+ numClassesInSegment := self moveClassesForwardsIn: arrayOfObjects.
+
+ "The scheme is to copy the objects into segmentWordArray, and then map the oops in segmentWordArray.
- "The scheme is to copy the objects into segmentWordArray, and then map the oops in sementWordArray.
  Therefore the primitive needs to both map efficiently originals to copies in segmentWordArray and
+ be able to undo any side-effects if the primitive fails because either segmentWordArray or outPointerArray
+ is too small.  The mapping is done by having the objects to be stored in arrayOfObjects refer to their mapped
+ locations through their first field, just like a forwarding pointer, but without becoming a forwarder, saving their
+ first field in savedFirstFields, and the objects in outPointerArray pointing to tehir locations in the outPointerArray
+ through their identityHashes, saved in savedOutHashes.
+ Since arrayOfObjects and its savedFirstFields, and outPointerArray and its saved hashes, can be enumerated
- be able to undo any side-effects if the primitive fails because either sementWordArray or outPointerArray
- is too small.  The mapping is done by having the originals (either the objects in arrayOfObjects or the
- objects in outPointerArray) refer to their mapped locations through their identityHash, and saving their
- identityHashes in two ByteArrays, one that mirrors arrayOfObjects, and one that mirrors outPointerArray.
- Since arrayOfObjects and its saved hashes, and outPointerArray and its saved hashes, can be enumerated
  side-by-side, the hashes can be restored to the originals.  So the hash of an object in arrayOfObjects
  is set to its offset in segmentWordArray / self allocationUnit, and the hash of an object in outPointerArray
  is set to its index in outPointerArray plus the top hash bit.  Oops in segmentWordArray are therefore
  mapped by accessing the original oop's identityHash, testing the bottom bit to distinguish between internal
  and external oops.  The saved hash arrays are initialized with an out-of-range hash value so that the first
  unused entry can be identified."
 
+ savedFirstFields := self allocateSlots: (self numSlotsOf: arrayOfObjects)
+ format: self wordIndexableFormat
+ classIndex: self wordSizeClassIndexPun.
- savedInHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: arrayOfObjects) * 4)
- format: self firstLongFormat
- classIndex: self thirtyTwoBitLongsClassIndexPun.
  savedOutHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: outPointerArray) * 4)
  format: self firstLongFormat
  classIndex: self thirtyTwoBitLongsClassIndexPun.
+ (savedFirstFields isNil or: [savedOutHashes isNil]) ifTrue:
- (savedInHashes isNil or: [savedOutHashes isNil]) ifTrue:
  [self freeObject: arrayOfObjects.
  ^PrimErrNoMemory].
 
+ self fillObj: savedFirstFields numSlots: (self numSlotsOf: savedFirstFields) with: 0.
+ self fillObj: savedOutHashes numSlots: (self numSlotsOf: savedOutHashes) with: self savedOutHashFillValue.
- fillValue := self wordSize = 4 ifTrue: [self maxIdentityHash + 1] ifFalse: [self maxIdentityHash + 1 << 32 + (self maxIdentityHash + 1)].
- self fillObj: savedInHashes numSlots: (self numSlotsOf: savedInHashes) with: fillValue.
- self fillObj: savedOutHashes numSlots: (self numSlotsOf: savedOutHashes) with: fillValue.
 
- "Both to expand the max size of segment and to reduce the length of the
- load-time pass that adds classes to the class table, move classes to the
- front of arrayOfObjects, leaving the root array as the first element."
- self moveClassesForwardsIn: arrayOfObjects.
-
  segAddr := segmentWordArray + self baseHeaderSize.
  endSeg := self addressAfter: segmentWordArray.
 
  "Write a version number for byte order and version check."
  segAddr >= endSeg ifTrue: [^PrimErrGenericFailure].
  self long32At: segAddr put: self imageSegmentVersion.
  self long32At: segAddr + 4 put: self imageSegmentVersion.
  segStart := segAddr := segAddr + self allocationUnit.
 
+ "Copy all reachable objects to the segment, setting the marked bit for all objects (clones) in the segment,
+ and the remembered bit for all classes (clones) in the segment."
- "Copy all reachable objects to the segment."
  0 to: (self numSlotsOf: arrayOfObjects) - 1 do:
  [:i| | newSegAddrOrError objOop |
+ "Check that classes in the segment are addressible.  Since the top bit of the hash field is used to tag
+ classes external to the segment, the segment offset must not inadvertently set this bit.  This limit still
+ allows for a million or more classes."
+ (i = numClassesInSegment
+ and: [segAddr - segStart / self allocationUnit + self lastClassIndexPun >= TopHashBit]) ifTrue:
+ [^self return: PrimErrLimitExceeded
+ restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields
+ and: outPointerArray savedHashes: savedOutHashes].
  objOop := self fetchPointer: i ofObject: arrayOfObjects.
  self deny: ((self isImmediate: objOop) or: [self isForwarded: objOop]).
+ newSegAddrOrError := self copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg savedFirstFields: savedFirstFields index: i.
- self storeLong32: i ofObject: savedInHashes withValue: (self rawHashBitsOf: objOop).
- newSegAddrOrError := self copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg.
  newSegAddrOrError < segStart ifTrue:
  [^self return: newSegAddrOrError
+ restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields
- restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
  and: outPointerArray savedHashes: savedOutHashes].
  segAddr := newSegAddrOrError].
 
  "Check that it can be safely shortened."
  (endSeg ~= segAddr
  and: [endSeg - segAddr < (self baseHeaderSize + self bytesPerOop)]) ifTrue:
  [^self return: PrimErrWritePastObject
+ restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields
- restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
  and: outPointerArray savedHashes: savedOutHashes].
 
  "Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
+ have their first field pointing to the corresponding copy in segmentWordArray."
- have their hashes set to point to their copies in segmentWordArray."
  (outIndex := self mapOopsFrom: segStart
  to: segAddr
  outPointers: outPointerArray
  outHashes: savedOutHashes) < 0 ifTrue: "no room in outPointers; fail"
  [^self return: PrimErrBadIndex
+ restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields
- restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
  and: outPointerArray savedHashes: savedOutHashes].
 
  "We're done.  Shorten the results, restore hashes and return."
  self shorten: segmentWordArray toIndexableSize: segAddr - (segmentWordArray + self baseHeaderSize) / 4.
  self shorten: outPointerArray toIndexableSize: outIndex.
  ^self return: PrimNoErr
+ restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields
- restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
  and: outPointerArray savedHashes: savedOutHashes!

Item was changed:
  ----- Method: SpurMemoryManager>>storePointerImmutabilityCheck:ofObject:withValue: (in category 'object access') -----
  storePointerImmutabilityCheck: fieldIndex ofObject: objOop withValue: valuePointer
  "Note must check here for stores of young objects into old ones."
  <inline: true> "Must be inlined for the normal send in cannotAssign:to:withIndex:"
 
  self cppIf: IMMUTABILITY ifTrue:
  [self deny: (self isImmediate: objOop).
  (self isImmutable: objOop) ifTrue:
  [^coInterpreter cannotAssign: valuePointer to: objOop withIndex: fieldIndex]].
+
+ self storePointer: fieldIndex ofObject: objOop withValue: valuePointer!
-
- ^self storePointer: fieldIndex ofObject: objOop withValue: valuePointer!

Item was added:
+ ----- Method: SpurMemoryManager>>updatePostScavenge: (in category 'image segment in/out') -----
+ updatePostScavenge: anObj
+ <inline: true>
+ ^(self isForwarded: anObj) ifTrue: [self followForwarded: anObj] ifFalse: [anObj]!

Item was changed:
  ----- Method: StackInterpreter>>checkInterpreterIntegrity (in category 'object memory support') -----
  checkInterpreterIntegrity
  "Perform an integrity/leak check using the heapMap.  Assume
  clearLeakMapAndMapAccessibleObjects has set a bit at each
  object's header.  Check that all oops in the interpreter's state
  points to a header.  Answer 0 if all checks pass."
  | flags |
  flags := 0.
  (objectMemory checkOopIntegrity: objectMemory specialObjectsOop named: 'specialObjectsOop')ifFalse:
  [flags := 1].
  "No longer check messageSelector; it is ephemeral, not living beyond message lookup.
  (objectMemory isNonImmediate: messageSelector) ifTrue:
  [(objectMemory checkOopIntegrity: messageSelector named: 'messageSelector')ifFalse:
  [ok := false]]."
+ "Work around the primitiveDoPrimitiveWithArgs hack"
+ (objectMemory hasSpurMemoryManagerAPI
+ and: [objectMemory isIntegerObject: newMethod]) ifFalse:
+ [(objectMemory checkOopIntegrity: newMethod named: 'newMethod')ifFalse:
+ [flags := flags + 2]].
- (objectMemory checkOopIntegrity: newMethod named: 'newMethod')ifFalse:
- [flags := flags + 2].
  "No longer check lkupClass; it is ephemeral, not living beyond message lookup.
  (objectMemory checkOopIntegrity: lkupClass named: 'lkupClass')ifFalse:
  [ok := false]."
  (objectMemory checkOopIntegrity: profileProcess named: 'profileProcess')ifFalse:
  [flags := flags + 4].
  (objectMemory checkOopIntegrity: profileMethod named: 'profileMethod')ifFalse:
  [flags := flags + 8].
  (objectMemory checkOopIntegrity: profileSemaphore named: 'profileSemaphore')ifFalse:
  [flags := flags + 16].
  tempOop = 0 ifFalse:
  [(objectMemory checkOopIntegrity: tempOop named: 'tempOop')ifFalse:
  [flags := flags + 32]].
  tempOop2 = 0 ifFalse:
  [(objectMemory checkOopIntegrity: tempOop2 named: 'tempOop2')ifFalse:
  [flags := flags + 64]].
  tempOop3 = 0 ifFalse:
  [(objectMemory checkOopIntegrity: tempOop3 named: 'tempOop3')ifFalse:
  [flags := flags + 128]].
 
  "Callback support - check suspended callback list"
  1 to: jmpDepth do:
  [:i|
  (objectMemory checkOopIntegrity: (suspendedCallbacks at: i) named: 'suspendedCallbacks' index: i) ifFalse:
  [flags := flags + 256].
  (objectMemory checkOopIntegrity: (suspendedMethods at: i) named: 'suspendedMethods' index: i) ifFalse:
  [flags := flags + 512]].
 
  self checkLogIntegrity ifFalse:
  [flags := flags + 1024].
 
  ^flags!

Item was changed:
  ----- Method: StackInterpreter>>storeLiteralVariable:withValue: (in category 'stack bytecodes') -----
  storeLiteralVariable: literalIndex withValue: anObject
  | litVar |
  litVar := self literal: literalIndex.
  "push/store/popLiteralVariable all fetch a literal, and either read or write the literal's value field.
  The fetch of the literal needs an explicit check (otherwise we would have to scan all literals in
  all methods in the stack zone, and the entire method on return, and global variables are relatively
  rare; in my work image 8.7% of literals are globals)."
 
  (objectMemory isForwarded: litVar) ifTrue:
+ [litVar := objectMemory followForwarded: litVar.
+ self literal: literalIndex ofMethod: method put: litVar].
+ objectMemory storePointerImmutabilityCheck: ValueIndex ofObject: litVar withValue: anObject!
- [litVar := objectMemory followForwarded: litVar].
- ^objectMemory storePointerImmutabilityCheck: ValueIndex ofObject: litVar withValue: anObject!

Item was changed:
  ----- Method: StackInterpreterSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'file primitives') -----
  makeDirEntryName: entryName size: entryNameSize
  createDate: createDate modDate: modifiedDate
+ isDir: dirFlag fileSize: fileSize
- isDir: dirFlag fileSize: fileSize
 
+ ^(pluginList
+ detect: [:assoc| assoc key = 'FilePlugin']
+ ifNone: [self error: 'this message should not be sent unless the FilePlugin has been loaded']) value
+ makeDirEntryName: entryName size: entryNameSize
+ createDate: createDate modDate: modifiedDate
+ isDir: dirFlag fileSize: fileSize!
- | modDateOop createDateOop nameString results |
- <var: 'entryName' type: 'char *'>
-
- results := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: 5.
- nameString := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: entryNameSize.
- createDateOop := self positive32BitIntegerFor: createDate.
- modDateOop := self positive32BitIntegerFor: modifiedDate.
-
- 1 to: entryNameSize do:
- [ :i |
- objectMemory storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue].
-
- objectMemory storePointerUnchecked: 0 ofObject: results withValue: nameString.
- objectMemory storePointerUnchecked: 1 ofObject: results withValue: createDateOop.
- objectMemory storePointerUnchecked: 2 ofObject: results withValue: modDateOop.
- dirFlag
- ifTrue: [ objectMemory storePointerUnchecked: 3 ofObject: results withValue: objectMemory trueObject ]
- ifFalse: [ objectMemory storePointerUnchecked: 3 ofObject: results withValue: objectMemory falseObject ].
- objectMemory storePointerUnchecked: 4 ofObject: results withValue: (objectMemory integerObjectOf: fileSize).
- ^ results!

Item was changed:
  ----- Method: StackInterpreterSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize:posixPermissions:isSymlink: (in category 'file primitives') -----
  makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize posixPermissions: posixPermissions isSymlink: symlinkFlag
- <option: #PharoVM>
- <var: 'entryName' type: 'char *'>
 
+ ^(pluginList
+ detect: [:assoc| assoc key = 'FilePlugin']
+ ifNone: [self error: 'this message should not be sent unless the FilePlugin has been loaded']) value
+ makeDirEntryName: entryName size: entryNameSize
+ createDate: createDate modDate: modifiedDate
+ isDir: dirFlag fileSize: fileSize
+ posixPermissions: fileSize isSymlink: symlinkFlag!
- | modDateOop createDateOop nameString results |
-
- results := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: 7.
- nameString := objectMemory instantiateClass: (objectMemory splObj: ClassString) indexableSize: entryNameSize.
- createDateOop := self positive32BitIntegerFor: createDate.
- modDateOop := self positive32BitIntegerFor: modifiedDate.
-
- 1 to: entryNameSize do:
- [ :i |
- objectMemory storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue].
-
- objectMemory storePointerUnchecked: 0 ofObject: results withValue: nameString.
- objectMemory storePointerUnchecked: 1 ofObject: results withValue: createDateOop.
- objectMemory storePointerUnchecked: 2 ofObject: results withValue: modDateOop.
- dirFlag
- ifTrue: [ objectMemory storePointerUnchecked: 3 ofObject: results withValue: objectMemory trueObject ]
- ifFalse: [ objectMemory storePointerUnchecked: 3 ofObject: results withValue: objectMemory falseObject ].
- objectMemory storePointerUnchecked: 4 ofObject: results withValue: (objectMemory integerObjectOf: fileSize).
- objectMemory storePointerUnchecked: 5 ofObject: results withValue: (objectMemory integerObjectOf: posixPermissions).
- symlinkFlag
- ifTrue: [ objectMemory storePointerUnchecked: 6 ofObject: results withValue: objectMemory trueObject ]
- ifFalse: [ objectMemory storePointerUnchecked: 6 ofObject: results withValue: objectMemory falseObject ].
-
- ^ results!


Loading...