The Trunk: System-eem.1020.mcz

Eliot Miranda uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-eem.1020.mcz

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

Name: System-eem.1020
Author: eem
Time: 2 May 2018, 12:29:21.289681 pm
UUID: f492f156-8401-4575-9c03-d268326a41af
Ancestors: System-mt.1019

Move some reading methods up from NativeImageSegment that should be in ImageSegment.  Fix determining the image format in NativeImageSegment on load.  This reveals that byte reversal does /not/ work on 64-bit Spur (loking at the VM code it seems to reverse 32-bit units, which is almost certainly wrong for 64-bits, alhtough it is right for 32-bits).

=============== Diff against System-mt.1019 ===============

Item was added:
+ ----- Method: ImageSegment>>acceptSingleMethodSource: (in category 'fileIn/Out') -----
+ acceptSingleMethodSource: aDictionary
+
+ | oldClassInfo oldClassName ismeta newName actualClass selector |
+ oldClassInfo := (aDictionary at: #oldClassName) findTokens: ' '. "'Class' or 'Class class'"
+ oldClassName := oldClassInfo first asSymbol.
+ ismeta := oldClassInfo size > 1.
+
+ "must use class var since we may not be the same guy who did the initial work"
+
+ newName := RecentlyRenamedClasses ifNil: [
+ oldClassName
+ ] ifNotNil: [
+ RecentlyRenamedClasses at: oldClassName ifAbsent: [oldClassName]
+ ].
+ actualClass := Smalltalk at: newName.
+ ismeta ifTrue: [actualClass := actualClass class].
+ selector := actualClass newParser parseSelector: (aDictionary at: #methodText).
+ (actualClass compiledMethodAt: selector ifAbsent: [^self "hosed input"])
+ putSource: (aDictionary at: #methodText)
+ fromParseNode: nil
+ class: actualClass
+ category: (aDictionary at: #category)
+ withStamp: (aDictionary at: #changeStamp)
+ inFile: 2
+ priorMethod: nil.
+ !

Item was changed:
  ----- Method: ImageSegment>>comeFullyUpOnReload: (in category 'fileIn') -----
  comeFullyUpOnReload: smartRefStream
  "fix up the objects in the segment that changed size.  An object in the segment is the wrong size for the modern version of the class. Construct a fake class that is the old size.  Replace the modern class with the old one in outPointers.  Load the segment. Traverse the instances, making new instances by copying fields, and running conversion messages.  Keep the new instances.  Bulk forward become the old to the new.  Let go of the fake objects and classes.
  After the install (below), arrayOfRoots is filled in. Globalize new classes.  Caller may want to do some special install on certain objects in arrayOfRoots.
  May want to write the segment out to disk in its new form."
 
  | mapFakeClassesToReal receiverClasses rootsToUnhiberhate myProject existing forgetDoItsClass endianness |
 
  forgetDoItsClass := Set new.
  RecentlyRenamedClasses := nil. "in case old data hanging around"
  mapFakeClassesToReal := smartRefStream reshapedClassesIn: outPointers.
  "Dictionary of just the ones that change shape. Substitute them in outPointers."
  self fixCapitalizationOfSymbols.
+ endianness := self endianness.
- endianness := (segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little].
  segment := self loadSegmentFrom: segment outPointers: outPointers.
  arrayOfRoots := segment first.
  mapFakeClassesToReal isEmpty ifFalse: [
  self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream
  ].
  "When a Project is stored, arrayOfRoots has all objects in the project, except those in outPointers"
  arrayOfRoots do: [:importedObject |
  ((importedObject isMemberOf: WideString) or: [importedObject isMemberOf: WideSymbol]) ifTrue: [
  importedObject mutateJISX0208StringToUnicode.
  importedObject class = WideSymbol ifTrue: [
  "self halt."
  Symbol hasInterned: importedObject asString ifTrue: [:multiSymbol |
  multiSymbol == importedObject ifFalse: [
  importedObject becomeForward: multiSymbol.
  ].
  ].
  ].
  ].
  (importedObject isMemberOf: TTCFontSet) ifTrue: [
  existing := TTCFontSet familyName: importedObject familyName
  pointSize: importedObject pointSize. "supplies default"
  existing == importedObject ifFalse: [importedObject becomeForward: existing].
  ].
  ].
 
  receiverClasses := self restoreEndianness: endianness ~~ Smalltalk endianness. "rehash sets"
  smartRefStream checkFatalReshape: receiverClasses.
 
  "Classes in this segment."
  arrayOfRoots do: [:importedObject |
  importedObject class class == Metaclass ifTrue: [forgetDoItsClass add: importedObject. self  declare: importedObject]].
  rootsToUnhiberhate := OrderedCollection new.
  arrayOfRoots do: [:importedObject |
  ((importedObject isMemberOf: ScriptEditorMorph)
  or: [(importedObject isKindOf: TileMorph)
  or: [(importedObject isMemberOf: ScriptingTileHolder)
  or: [importedObject isKindOf: CompoundTileMorph]]]) ifTrue: [
  rootsToUnhiberhate add: importedObject
  ].
  (importedObject isMemberOf: Project) ifTrue: [
  myProject := importedObject.
  importedObject ensureChangeSetNameUnique.
  Project addingProject: importedObject.
  importedObject restoreReferences.
  self dependentsRestore: importedObject.
  ScriptEditorMorph writingUniversalTiles:
  ((importedObject projectPreferenceAt: #universalTiles) ifNil: [false])]].
 
  myProject ifNotNil: [
  myProject world setProperty: #thingsToUnhibernate toValue: rootsToUnhiberhate asArray.
  ].
 
  mapFakeClassesToReal isEmpty ifFalse: [
  mapFakeClassesToReal keysAndValuesDo: [:aFake :aReal |
  aFake removeFromSystemUnlogged.
  aFake becomeForward: aReal].
  SystemOrganization removeEmptyCategories].
  forgetDoItsClass do: [:c | c forgetDoIts].
  "^ self"
  !

Item was added:
+ ----- Method: ImageSegment>>endianness (in category 'fileIn/Out') -----
+ endianness
+ "Return which endian kind the incoming segment came from"
+
+ segment class isBits ifFalse:
+ ["Hope that primitive 98 did the right thing - anyway, we lost information about endianness, so pretend we share the image's endianness."
+ ^Smalltalk endianness].
+ ^(segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]!

Item was added:
+ ----- Method: ImageSegment>>restoreEndianness (in category 'fileIn/Out') -----
+ restoreEndianness
+ ^self restoreEndianness: self endianness ~~ Smalltalk endianness!

Item was added:
+ ----- Method: ImageSegment>>scanFrom: (in category 'fileIn/Out') -----
+ scanFrom: aStream
+ "Move source code from a fileIn to the changes file for classes in an ImageSegment.  Do not compile the methods.  They already came in via the image segment.  After the ImageSegment in the file, !!ImageSegment new!! captures control, and scanFrom: is called."
+ | val chunk |
+
+ [aStream atEnd] whileFalse:
+ [aStream skipSeparators.
+ val := (aStream peekFor: $!!)
+ ifTrue: ["Move (aStream nextChunk), find the method or class
+ comment, and install the file location bytes"
+ (Compiler evaluate: aStream nextChunk logged: false)
+ scanFromNoCompile: aStream forSegment: self]
+ ifFalse: [chunk := aStream nextChunk.
+ aStream checkForPreamble: chunk.
+ Compiler evaluate: chunk logged: true].
+ aStream skipStyleChunk].
+ "regular fileIn will close the file"
+ ^ val!

Item was added:
+ ----- Method: ImageSegment>>scanFrom:environment: (in category 'fileIn/Out') -----
+ scanFrom: aStream environment: anEnvironment
+ ^ self scanFrom: aStream!

Item was removed:
- ----- Method: NativeImageSegment>>acceptSingleMethodSource: (in category 'fileIn/Out') -----
- acceptSingleMethodSource: aDictionary
-
- | oldClassInfo oldClassName ismeta newName actualClass selector |
- oldClassInfo := (aDictionary at: #oldClassName) findTokens: ' '. "'Class' or 'Class class'"
- oldClassName := oldClassInfo first asSymbol.
- ismeta := oldClassInfo size > 1.
-
- "must use class var since we may not be the same guy who did the initial work"
-
- newName := RecentlyRenamedClasses ifNil: [
- oldClassName
- ] ifNotNil: [
- RecentlyRenamedClasses at: oldClassName ifAbsent: [oldClassName]
- ].
- actualClass := Smalltalk at: newName.
- ismeta ifTrue: [actualClass := actualClass class].
- selector := actualClass newParser parseSelector: (aDictionary at: #methodText).
- (actualClass compiledMethodAt: selector ifAbsent: [^self "hosed input"])
- putSource: (aDictionary at: #methodText)
- fromParseNode: nil
- class: actualClass
- category: (aDictionary at: #category)
- withStamp: (aDictionary at: #changeStamp)
- inFile: 2
- priorMethod: nil.
- !

Item was removed:
- ----- Method: NativeImageSegment>>endianness (in category 'fileIn/Out') -----
- endianness
- "Return which endian kind the incoming segment came from"
-
- segment class isBits ifFalse:
- ["Hope that primitive 98 did the right thing - anyway, we lost information about endianness, so pretend we share the image's endianness."
- ^Smalltalk endianness].
- ^(segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]!

Item was changed:
  ----- Method: NativeImageSegment>>loadSegmentFrom:outPointers: (in category 'read/write segment primitives') -----
  loadSegmentFrom: segmentWordArray outPointers: outPointerArray
  "Load segmentWordArray into the memory.  Adapt the primitive to the new API, which is to answer the array of loaded objects, the first of which should be the array of roots.  The primitive will install a binary image segment and return as its value the array
  of roots of the tree of objects represented.  Upon successful completion, the
  wordArray will have been becomed into anArray of the loaded objects.  So simply answer the segmentWordArray which will have becommed."
 
  | segmentFormat |
+ segmentFormat := self segmentFormatFrom: segmentWordArray first.
- segmentFormat := segmentWordArray first bitAnd: 16rFFFFFF.
  segmentFormat = Smalltalk imageFormatVersion ifTrue:
  [^(self primitiveLoadSegmentFrom: segmentWordArray outPointers: outPointerArray)
  ifNil: [self error: 'segment load failed']
  ifNotNil: [segmentWordArray]].
  segmentFormat >= 68000
  ifTrue:
  [Smalltalk wordSize = 4 ifTrue:
  [^(Spur64BitImageSegmentLoader new loadSegmentFrom: segmentWordArray outPointers: outPointerArray)]]
  ifFalse:
  [Smalltalk wordSize = 8 ifTrue:
  [^(Spur32BitImageSegmentLoader new loadSegmentFrom: segmentWordArray outPointers: outPointerArray)]].
  self error: 'segment version unrecognized'!

Item was removed:
- ----- Method: NativeImageSegment>>restoreEndianness (in category 'fileIn/Out') -----
- restoreEndianness
- ^self restoreEndianness: self endianness ~~ Smalltalk endianness!

Item was removed:
- ----- Method: NativeImageSegment>>scanFrom: (in category 'fileIn/Out') -----
- scanFrom: aStream
- "Move source code from a fileIn to the changes file for classes in an ImageSegment.  Do not compile the methods.  They already came in via the image segment.  After the ImageSegment in the file, !!ImageSegment new!! captures control, and scanFrom: is called."
- | val chunk |
-
- [aStream atEnd] whileFalse:
- [aStream skipSeparators.
- val := (aStream peekFor: $!!)
- ifTrue: ["Move (aStream nextChunk), find the method or class
- comment, and install the file location bytes"
- (Compiler evaluate: aStream nextChunk logged: false)
- scanFromNoCompile: aStream forSegment: self]
- ifFalse: [chunk := aStream nextChunk.
- aStream checkForPreamble: chunk.
- Compiler evaluate: chunk logged: true].
- aStream skipStyleChunk].
- "regular fileIn will close the file"
- ^ val!

Item was removed:
- ----- Method: NativeImageSegment>>scanFrom:environment: (in category 'fileIn/Out') -----
- scanFrom: aStream environment: anEnvironment
- ^ self scanFrom: aStream!

Item was added:
+ ----- Method: NativeImageSegment>>segmentFormatFrom: (in category 'private') -----
+ segmentFormatFrom: a32BitWord
+ "The first two words of a segment array contain the image format version of the system upon which the segment was generated, along with a top byte that is either $d or $s (from the 'does' in #doesNotUnderstand:).  But this may be encoded either in big-endian or little-endian format.  Since endianness may or may not have been changed, determining what the segment format is takes care."
+ | msc lsc |
+ msc := Character value: ((a32BitWord bitShift: -24) bitAnd: 255).
+ lsc := Character value: (a32BitWord bitAnd: 255).
+ (('ds' includes: msc)
+ and: ['ds' includes: lsc]) ifTrue:
+ [self error: 'ambiguous segment format'].
+ ('ds' includes: msc) ifTrue:
+ [^a32BitWord bitAnd: 16rFFFFFF].
+ ^((a32BitWord bitShift: -24) bitAnd: 16rFF)
+ + ((a32BitWord bitShift: -8) bitAnd: 16rFF00)
+ + ((a32BitWord bitShift: 8) bitAnd: 16rFF0000)!