The Trunk: System-eem.758.mcz

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

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

Name: System-eem.758
Author: eem
Time: 22 August 2015, 10:05:39.102 am
UUID: 7a2b1f7b-f8a8-463b-b65f-9131c5a9d069
Ancestors: System-ul.757

Reimplement the post-load enumeration of loaded objects to use the revised primitive available in the VMMaker.oscog-eem.1441 /3427 VMs that becomes the loaded segment into an Array of the loaded objects.  Hence endMarker disappears and allObjectsDo: is trivially implemented as do: sent to the segment.

This change requires users to upgrade their VMs but as the alternative is crashes in ImageSegment loads this is acceptable.  AFAIA this fixes ImageSegments in Spur but they clearly need pounding on.

=============== Diff against System-ul.757 ===============

Item was changed:
  Object subclass: #ImageSegment
+ instanceVariableNames: 'arrayOfRoots segment outPointers state segmentName fileName userRootCnt renamedClasses'
- instanceVariableNames: 'arrayOfRoots segment outPointers state segmentName fileName endMarker userRootCnt renamedClasses'
  classVariableNames: 'BiggestFileNumber RecentlyRenamedClasses'
  poolDictionaries: ''
  category: 'System-Object Storage'!
 
+ !ImageSegment commentStamp: 'eem 8/21/2015 18:55' prior: 0!
- !ImageSegment commentStamp: 'nice 3/25/2010 23:01' prior: 0!
  I represent a segment of Squeak address space.  I am created from an
  array of root objects.  After storing, my segment contains a binary
  encoding of every object accessible from my roots but not otherwise
  accessible from anywhere else in the system.  My segment contains
  outward pointers that are indices into my table of outPointers.
+ On load my segment is converted back into objects and becommed
+ into an Array of the loaded objects, so they can be enumerated.
+
  The main use of ImageSegments is to store Projects.  A dummy
  version of SmartRefStream traverses the Project.  Everything it finds
  is classified as either an object that is owned by the project (only
  pointed to inside the project), or an object outside the project that
  is pointed to from inside the project.  The objects that are
  completely owned by the project are compressed into pure binary form
  in an ImageSegment.  The outside objects are put in the 'outPointers'
  array.  The entire ImageSegment (binary part plus outPointers) is
  encoded in a SmartRefStream, and saved on the disk.  (aProject
  exportSegmentWithChangeSet:fileName:directory:) calls (anImageSegment
  writeForExportWithSources:inDirectory:changeSet:).
+
  Note that every object inside the project is put into the
  segment's arrayOfRoots.  This is because a dummy SmartRefStream to
  scan the project, in order to make intelligent decisions about what
  belongs in the project.
  See Project's class comment for what messages are sent to
  objects as they are unpacked in a new image.
 
  ---- Older Details ------
 
  The primary kind of image segment is an Export Segment.  It
  can be saved on a server and read into a completely different Squeak
  image.
  Old way to create one:
  (ImageSegment new copyFromRootsForExport: (Array with: Baz with: Baz class))
  writeForExport: 'myFile.extSeg'.
  Old way to create one for a project:
  (Project named: 'Play With Me - 3') exportSegment.
  To read it into another image:  Select 'myFile.extSeg' in a FileList,
  Menu 'load as project'.  It will install its classes automatically.
  If you need to see the roots array, it is temporarily stored in
  (SmartRefStream scannedObject).
 
  Most of 'states' of an ImageSegment are not used to export a project,
  and have been abandoned.
 
  When a segment is written out onto a file, it goes in a
  folder called <image name>_segs.  If your image is called
  "Squeak2.6.image", the folder "Squeak2.6_segs" must accompany the
  image whenever your move, copy, or rename it.
  Whenever a Class is in arrayOfRoots, its class (aClass class)
  must also be in the arrayOfRoots.
  There are two kinds of image segments.  Normal image segments
  are a piece of a specific Squeak image, and can only be read back
  into that image.  The image holds the array of outPointers that are
  necessary to turn the bits in the file into objects.
  To put out a normal segment that holds a Project (not the
  current project), execute (Project named: 'xxx') storeSegment.
 
 
  arrayOfRoots The objects that head the tree we will trace.
  segment The WordArray of raw bits of all objects in the tree.
  outPointers Oops of all objects outside the segment
  pointed to from inside.
  state (see below)
  segmentName Its basic name.  Often the name of a Project.
  fileName The local name of the file.  'Foo-23.seg'
- endMarker An object located in memory somewhere after a
- segment that has
- just been brought in.  To enumerate the objects in
- the segment, start at
- the segment and go to this object.
  userRootCnt number of roots submitted by caller.  Extras
  are added in preparation for saving.
 
  state that an ImageSegment may exist in...
 
  #activeCopy (has been copied, with the intent to
  become active)
  arrayOfRoots, segment, and outPointers have been created by
  copyFromRoots:.  The tree of objects has been encoded in the segment,
  but those objects are still present in the Squeak system.
 
  #active (segment is actively holding objects)
  The segment is now the only holder of tree of objects.  Each of the
  original roots has been transmuted into an ImageSegmentRootStub that
  refers back to this image segment.  The original objects in the
  segment will all be garbageCollected.
 
  #onFile
  The segment has been written out to a file and replaced by a file
  pointer.  Only ImageSegmentRootStubs and the array of outPointers
  remains in the image.  To get this far:
  (ImageSegment new copyFromRoots: (Array with: Baz with: Baz class))
  writeToFile: 'myFile.seg'.
 
  #inactive
  The segment has been brought back into memory and turned back into
  objects.  rootsArray is set, but the segment is invalid.
 
  #onFileWithSymbols
  The segment has been written out to a file, along with the text of
  all the symbols in the outPointers array, and replaced by a file
  pointer.  This reduces the size of the outPointers array, and also
  allows the system to reclaim any symbols that are not referred to
  from elsewhere in the image.  The specific format used is that of a
  literal array as follows:
  #(symbol1 symbol2 # symbol3 symbol4 'symbolWithSpaces' # symbol5).
  In this case, the original outPointers array was 8 long, but the
  compacted table of outPointers retains only two entries.  These get
  inserted in place of the #'s in the array of symbols after it is read
  back in.  Symbols with embedded spaces or other strange characters
  are written as strings, and converted back to symbols when read back
  in.  The symbol # is never written out.
  NOTE: All IdentitySets or dictionaries must be rehashed when
  being read back from this format.  The symbols are effectively
  internal.  (No, not if read back into same image.  If a different
  image, then use #imported.  -tk)
 
  #imported
  The segment is on an external file or just read in from one.  The
  segment and outPointers are meant to be read into a foreign image.
  In this form, the image segment can be read from a URL, and
  installed.  A copy of the original array of root objects is
  constructed, with former outPointers bound to existing objects in the
  host system.
  (Any Class inside the segment MUST be in the arrayOfRoots.
  This is so its association can be inserted into Smalltalk.  The
  class's metaclass must be in roots also.  Methods that are in
  outPointers because blocks point at them, were found and added to the
  roots.
  All IdentitySets and dictionaries are rehashed when being
  read back from exported segments.)
 
 
  To discover why only some of the objects in a project are being
  written out, try this (***Destructive Test***).  This breaks lots of
  backpointers in the target project, and puts up an array of
  suspicious objects, a list of the classes of the outPointers, and a
  debugger.
  "Close any transcripts in the target project"
  World currentHand objectToPaste ifNotNil: [
  self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs,
  World currentHand objectToPaste printString].
  PV := Project named: 'xxxx'.
  (IS := ImageSegment new) findRogueRootsImSeg:
  (Array with: PV world presenter with: PV world).
  IS findOwnersOutPtrs. "Optionally: write a file with owner chains"
  "Quit and DO NOT save"
 
  When an export image segment is brought into an image, it is like an
  image starting up.  Certain startUp messages need to be run.  These
  are byte and word reversals for nonPointer data that comes from a
  machine of the opposite endianness.  #startUpProc passes over all
  objects in the segment, and:
  The first time an instance of class X is encountered, (msg _
  X startUpFrom: anImageSegment) is sent.  If msg is nil, the usual
  case, it means that instances of X do not need special work.  X is
  included in the IdentitySet, noStartUpNeeded.  If msg is not nil,
  store it in the dictionary, startUps (aClass -> aMessage).
  When a later instance of X is encountered, if X is in
  noStartUpNeeded, do nothing.  If X is in startUps, send the message
  to the instance.  Typically this is a message like #swapShortObjects.
  Every class that implements #startUp, should see if it needs
  a parallel implementation of #startUpFrom:.  !

Item was changed:
  ----- Method: ImageSegment>>allObjectsDo: (in category 'access') -----
  allObjectsDo: aBlock
  "Enumerate all objects that came from this segment.  NOTE this assumes that the segment was created (and extracted).  After the segment has been installed (install), this method allows you to enumerate its objects."
+ self checkAndReportLoadError.
+ segment do: aBlock!
- | obj |
-
- endMarker == nil ifTrue: [
- ^ self error: 'Just extract and install, don''t writeToFile:'].
- segment size ~= 1 ifTrue: [
- ^ self error: 'Vestigial segment size must be 1 (version word)'].
-
- obj := segment nextObject.  "Start with the next object after the vestigial header"
- [obj == endMarker] whileFalse:  "Stop at the next object after the full segment"
- [aBlock value: obj.
- obj := obj nextObject].  "Step through the objects installed from the segment."!

Item was removed:
- ----- Method: ImageSegment>>cc:new:current:fake:refStrm: (in category 'compact classes') -----
- cc: ind new: inTheSeg current: inTheImage fake: fakeCls refStrm: smartRefStream
- "Sort out all the cases and decide what to do.  Every Fake class is uncompacted before having insts converted.  As the segment is installed, instances of reshaped compact classes will have the wrong class.  Trouble cases:
- 1) Existing class is compact in the segment and not compact here.  Make that compact, (error if that slot is used), load the segment.  If an class was just filed in, it is an existing class as far as we are concerned.
- 2) A compact class has a different shape.  We created a Fake class.  Load the segment, with instances in the seg having the Wrong Class!!!!  Find the bad instancees, and copy them over to being the real class.
- 3) An existing class is not compact in the segment, but is in the image.  Just let the new instance be uncompact.  That is OK, and never reaches this code.
- A class that is a root in this segment cannot be compact.  That is not allowed."
-
- (inTheImage == nil) & (fakeCls == nil) ifTrue: ["case 1 and empty slot"
- inTheSeg becomeCompactSimplyAt: ind.  ^ true].
-
- (inTheImage == inTheSeg) & (fakeCls == nil) ifTrue: ["everything matches"
- ^ true].
-
- inTheImage ifNil: ["reshaped and is an empty slot"
- fakeCls becomeCompactSimplyAt: ind.  ^ true].
- "comeFullyUpOnReload: will clean up"
-
- (inTheSeg == String and:[inTheImage == ByteString]) ifTrue:[
- "ar 4/10/2005: Workaround after renaming String to ByteString"
- ^true
- ].
-
- "Is the image class really the class we are expecting?  inTheSeg came in as a DiskProxy, and was mapped if it was renamed!!"
- inTheImage == inTheSeg ifFalse: [
- self inform: 'The incoming class ', inTheSeg name, ' wants compact class \location ', ind printString, ', but that is occupied by ', inTheImage name, '.  \This file cannot be read into this system.  The author of the file \should make the class uncompact and create the file again.' withCRs.
- ^ false].
-
- "Instances of fakeCls think they are compact, and thus will say they are instances of the class inTheImage, which is a different shape.  Just allow this to happen.  Collect them and remap them as soon as the segment is installed."
- ^ true!

Item was added:
+ ----- Method: ImageSegment>>checkAndReportLoadError (in category 'error checking') -----
+ checkAndReportLoadError
+ "Check that the load has occurred.  A side-efect of the load primitive is to become
+ the segment into an Array of the loaded objects, so they can be enumerated.  If
+ this hasn't happened also check if the segment is a zero-length word array which
+ indicates we're running on an older Spur VM that doesn't do the become."
+ segment isArray ifTrue: [^self]. "ok"
+ (segment class == WordArrayForSegment
+ and: [segment size = 0]) ifTrue:
+ [^self error: 'The load primitive has not becomed segment into an Array of the loaded objects. \Please upgrade your virtual machine to one that does this.' withCRs].
+ ^self error: 'Segment has not been becommed into the loaded objects'!

Item was changed:
  ----- Method: ImageSegment>>comeFullyUpOnReload: (in category 'fileIn/Out') -----
  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 forgetDoItsClasses |
- | mapFakeClassesToReal ccFixups receiverClasses rootsToUnhiberhate myProject forgetDoItsClasses |
 
  forgetDoItsClasses := 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."
- "Dictionary of just the ones that change shape. Substitute them in outPointers."
- ccFixups := self remapCompactClasses: mapFakeClassesToReal
- refStrm: smartRefStream.
- ccFixups ifFalse: [^ self error: 'A class in the file is not compatible'].
- endMarker := segment nextObject. "for enumeration of objects"
- endMarker == 0 ifTrue: [endMarker := 'End' clone].
  self fixCapitalizationOfSymbols.
  arrayOfRoots := self loadSegmentFrom: segment outPointers: outPointers.
+ self checkAndReportLoadError.
  "Can't use install.  Not ready for rehashSets"
  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 | | existing |
  ((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 isKindOf: TTCFontSet) ifTrue: [
+ existing := TTCFontSet
+ familyName: importedObject familyName
+ pointSize: importedObject pointSize. "supplies default"
- existing := TTCFontSet familyName: importedObject familyName
- pointSize: importedObject pointSize. "supplies default"
  existing == importedObject ifFalse: [importedObject becomeForward: existing].
  ].
  ].
  "Smalltalk garbageCollect.   MultiSymbol rehash.  These take time and are not urgent, so don't to them.  In the normal case, no bad MultiSymbols will be found."
 
  receiverClasses := self restoreEndianness. "rehash sets"
  smartRefStream checkFatalReshape: receiverClasses.
 
  "Classes in this segment."
  arrayOfRoots do: [:importedObject |
  importedObject class class == Metaclass ifTrue: [
  forgetDoItsClasses add: importedObject.
  self declare: importedObject]].
  arrayOfRoots do: [:importedObject |
+ importedObject isCompiledMethod ifTrue: [
- (importedObject isKindOf: CompiledMethod) ifTrue: [
  importedObject sourcePointer > 0 ifTrue: [importedObject zapSourcePointer]].
  (importedObject isKindOf: Project) ifTrue: [
  myProject := importedObject.
  importedObject ensureChangeSetNameUnique.
  Project addingProject: importedObject.
  importedObject restoreReferences.
  self dependentsRestore: importedObject]].
 
  rootsToUnhiberhate := arrayOfRoots select: [:importedObject |
  importedObject respondsTo: #unhibernate
  "ScriptEditors and ViewerFlapTabs"
  ].
  myProject ifNotNil: [
  myProject world setProperty: #thingsToUnhibernate toValue: rootsToUnhiberhate asArray.
  ].
 
  mapFakeClassesToReal isEmpty ifFalse: [
  mapFakeClassesToReal keysAndValuesDo: [:aFake :aReal |
- aFake indexIfCompact > 0 ifTrue: [aFake becomeUncompact].
  aFake removeFromSystemUnlogged.
  "do not assign the fake's hash to the real class"
  aFake becomeForward: aReal copyHash: false].
  SystemOrganization removeEmptyCategories].
  forgetDoItsClasses do: [:c | c forgetDoIts].
  "^ self"
  !

Item was changed:
  ----- Method: ImageSegment>>copyFromRoots:sizeHint:areUnique: (in category 'read/write segment') -----
  copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: areUnique
  "Copy a tree of objects into a WordArray segment.  The copied objects in the segment are not in the normal Squeak space.  
  [1] For exporting a project.  Objects were enumerated by ReferenceStream and aRootArray has them all.
  [2] For exporting some classes.  See copyFromRootsForExport:. (Caller must hold Symbols, or they will not get registered in the target system.)
  [3] For 'local segments'.  outPointers are kept in the image.
  If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside.  (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.)"
  | segmentWordArray outPointerArray segSize rootSet uniqueRoots |
  aRootArray ifNil: [self errorWrongState].
  uniqueRoots := areUnique
  ifTrue: [aRootArray]
  ifFalse: [rootSet := IdentitySet new: aRootArray size * 3.
  uniqueRoots := OrderedCollection new.
  1 to: aRootArray size do: [:ii | "Don't include any roots twice"
  (rootSet includes: (aRootArray at: ii))
  ifFalse: [
  uniqueRoots addLast: (aRootArray at: ii).
  rootSet add: (aRootArray at: ii)]
  ifTrue: [userRootCnt ifNotNil: ["adjust the count"
  ii <= userRootCnt ifTrue: [userRootCnt := userRootCnt - 1]]]].
  uniqueRoots].
  arrayOfRoots := uniqueRoots asArray.
  rootSet := uniqueRoots := nil. "be clean"
  userRootCnt ifNil: [userRootCnt := arrayOfRoots size].
- arrayOfRoots do: [:aRoot |
- aRoot indexIfCompact > 0 ifTrue: [
- self error: 'Compact class ', aRoot name, ' cannot be a root']].
  outPointers := nil. "may have used this instance before"
  segSize := segSizeHint > 0 ifTrue: [segSizeHint *3 //2] ifFalse: [50000].
 
  ["Guess a reasonable segment size"
  segmentWordArray := WordArrayForSegment new: segSize.
  outPointerArray := [Array new: segSize // 20] ifError: [
  state := #tooBig.  ^ self].
  "Smalltalk garbageCollect."
  (self storeSegmentFor: arrayOfRoots
  into: segmentWordArray
  outPointers: outPointerArray) == nil]
  whileTrue:
  ["Double the segment size and try again"
  segmentWordArray := outPointerArray := nil.
  segSize := segSize * 2].
  segment := segmentWordArray.
  outPointers := outPointerArray.
+ state := #activeCopy
- state := #activeCopy.
- endMarker := segment nextObject. "for enumeration of objects"
- endMarker == 0 ifTrue: [endMarker := 'End' clone].
  !

Item was changed:
  ----- Method: ImageSegment>>install (in category 'read/write segment') -----
  install
  "This operation retrieves the segment if necessary from file storage, installs it in memory, and replaces (using become:) all the root stubs with the reconstructed roots of the segment."
 
  | newRoots |
  state = #onFile ifTrue: [self readFromFile].
+ state = #onFileWithSymbols ifTrue:
+ [self readFromFileWithSymbols].
- state = #onFileWithSymbols ifTrue: [self readFromFileWithSymbols.
- endMarker := segment nextObject. "for enumeration of objects"
- endMarker == 0 ifTrue: [endMarker := 'End' clone]].
  (state = #active) | (state = #imported) ifFalse: [self errorWrongState].
  newRoots := self loadSegmentFrom: segment outPointers: outPointers.
+ self checkAndReportLoadError.
  state = #imported
  ifTrue: ["just came in from exported file"
  arrayOfRoots := newRoots]
  ifFalse: [
  arrayOfRoots elementsForwardIdentityTo: newRoots].
  state := #inactive.
  Beeper beepPrimitive!

Item was changed:
  ----- Method: ImageSegment>>loadSegmentFrom:outPointers: (in category 'primitives') -----
  loadSegmentFrom: segmentWordArray outPointers: outPointerArray
+ "This 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.  If this
+ primitive should fail, it will have destroyed the contents of the segment wordArray."
- "This 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 transmuted into an object of zero length.  If this primitive should fail, it will have destroyed the contents of the segment wordArray."
 
+ <primitive: 99 error: ec> "successful completion returns the array of roots"
+ ^nil "failure returns nil"!
- <primitive: 99> "successful completion returns the array of roots"
- ^ nil "failure returns nil"!

Item was changed:
  ----- Method: ImageSegment>>readFromFile (in category 'read/write segment') -----
  readFromFile
  "Read in a simple segment.  Use folder of this image, even if remembered as previous location of this image"
 
  | ff realName |
  realName := self class folder, FileDirectory slash, self localName.
  ff := FileStream readOnlyFileNamed: realName.
  segment := ff nextWordsInto: (WordArrayForSegment new: ff size//4).
- endMarker := segment nextObject. "for enumeration of objects"
- endMarker == 0 ifTrue: [endMarker := 'End' clone].
  ff close.
  state := #active!

Item was changed:
  ----- Method: ImageSegment>>rehashSets (in category 'fileIn/Out') -----
  rehashSets
  "I have just been brought in and converted to live objects.  Find all Sets and Dictionaries in the newly created objects and rehash them.  Segment is near then end of memory, since is was newly brought in (and a new object created for it).
  Also, collect all classes of receivers of blocks.  Return them.  Caller will check if they have been reshaped."
 
+ | hashedCollections receiverClasses |
- | object hashedCollections receiverClasses inSeg |
- object := segment.
  hashedCollections := OrderedCollection new.
  "have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one."
  receiverClasses := IdentitySet new.
+ self allObjectsDo:
+ [:object|
+ object isInMemory ifTrue:
+ [(object isCollection and: [object isKindOf: HashedCollection]) ifTrue:
+ [hashedCollections add: object].
+ (object isBlock or: [object isContext]) ifTrue:
+ [receiverClasses add: object receiver class]]].
- inSeg := true.
- [object := object nextObject.  
- object == endMarker ifTrue: [inSeg := false]. "off end"
- object isInMemory ifTrue: [
- (object isKindOf: HashedCollection) ifTrue: [hashedCollections add: object].
- object isBlock ifTrue: [inSeg ifTrue: [
- receiverClasses add: object receiver class]].
- object class == MethodContext ifTrue: [inSeg ifTrue: [
- receiverClasses add: object receiver class]].
- ].
- object == 0] whileFalse.
  hashedCollections do: [ :each | each compact ]. "our purpose"
+ ^receiverClasses "our secondary job"!
- ^ receiverClasses "our secondary job"
- !

Item was removed:
- ----- Method: ImageSegment>>remapCompactClasses:refStrm: (in category 'compact classes') -----
- remapCompactClasses: mapFakeClassesToReal refStrm: smartRefStream
- | ccArray current fake info |
- "See if our compact classes are compatible with this system.  Convert to what the system already has.  If we are adding a new class, it has already been filed in.  A compact class may not be a root."
-
- (outPointers at: (outPointers size - 1)) = 1717 ifFalse: [^ true].
- ccArray := outPointers last.
- current := Smalltalk compactClassesArray.
- 1 to: ccArray size do: [:ind |
- (ccArray at: ind) ifNotNil: ["is compact in the segment"
- fake := mapFakeClassesToReal keyAtValue: (current at: ind) ifAbsent: [nil].
- info := self cc: ind new: (ccArray at: ind) current: (current at: ind)
- fake: fake refStrm: smartRefStream.
- info ifFalse: [^ false]]].
- ^ true!

Item was changed:
  ----- Method: ImageSegment>>reshapeClasses:refStream: (in category 'fileIn/Out') -----
+ reshapeClasses: mapFakeClassesToReal refStream: smartRefStream
- reshapeClasses: mapFakeClassesToReal refStream: smartRefStream
 
  | bads allVarMaps partials in out perfect |
 
  self flag: #bobconv.
 
  partials := OrderedCollection new.
  bads := OrderedCollection new.
  allVarMaps := IdentityDictionary new.
+ mapFakeClassesToReal keysAndValuesDo: [ :aFakeClass :theRealClass |
+ aFakeClass allInstances do: [ :misShapen |
- mapFakeClassesToReal keysAndValuesDo: [ :aFakeClass :theRealClass | | insts |
- (theRealClass indexIfCompact > 0) "and there is a fake class"
- ifFalse: [insts := aFakeClass allInstances]
- ifTrue: ["instances have the wrong class.  Fix them before anyone notices."
- insts := OrderedCollection new.
- self allObjectsDo: [:obj | obj class == theRealClass ifTrue: [insts add: obj]].
- ].
- insts do: [ :misShapen |
  perfect := smartRefStream convert1: misShapen to: theRealClass allVarMaps: allVarMaps.
+ bads
+ detect: [ :x | x == misShapen]
- bads
- detect: [ :x | x == misShapen]
  ifNone: [
  bads add: misShapen.
  partials add: perfect
  ].
  ].
  ].
  bads isEmpty ifFalse: [
  bads asArray elementsForwardIdentityTo: partials asArray
  ].
 
  in := OrderedCollection new.
  out := OrderedCollection new.
  partials do: [ :each |
  perfect := smartRefStream convert2: each allVarMaps: allVarMaps.
+ in
- in
  detect: [ :x | x == each]
  ifNone: [
  in add: each.
  out add: perfect
  ]
  ].
  in isEmpty ifFalse: [
  in asArray elementsForwardIdentityTo: out asArray
  ].
  !

Item was changed:
  ----- Method: ImageSegment>>restoreEndianness (in category 'fileIn/Out') -----
  restoreEndianness
  "Fix endianness (byte order) of any objects not already fixed.  Do this by discovering classes that need a startUp message sent to each instance, and sending it.
  I have just been brought in and converted to live objects.  Find all Sets and Dictionaries in the newly created objects and rehash them.  Segment is near then end of memory, since is was newly brought in (and a new object created for it).
  Also, collect all classes of receivers of blocks which refer to instance variables.  Return them.  Caller will check if they have been reshaped."
 
+ | hashedCollections receiverClasses noStartUpNeeded startUps |
- | object hashedCollections receiverClasses inSeg noStartUpNeeded startUps cls msg |
 
- object := segment.
  hashedCollections := OrderedCollection new.
- "have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one."
  receiverClasses := IdentitySet new.
  noStartUpNeeded := IdentitySet new. "classes that don't have a per-instance startUp message"
  startUps := IdentityDictionary new. "class -> MessageSend of a startUp message"
+ self allObjectsDo:
+ [:object| | cls msg |
+ object isInMemory ifTrue:
+ [(object isCollection and: [object isKindOf: HashedCollection]) ifTrue:
+ [hashedCollections add: object].
+ (object isContext and: [object hasInstVarRef]) ifTrue:
+ [receiverClasses add: object receiver class]].
+ (noStartUpNeeded includes: object class) ifFalse:
+ [cls := object class.
+ (msg := startUps at: cls ifAbsent: nil) ifNil:
+ [msg := cls startUpFrom: self. "a Message, if we need to swap bytes this time"
+ msg ifNil: [noStartUpNeeded add: cls]
+ ifNotNil: [startUps at: cls put: msg]].
+ msg ifNotNil: [msg sentTo: object]]].
- inSeg := true.
- [object := object nextObject.  "all the way to the end of memory to catch remade objects"
- object == endMarker ifTrue: [inSeg := false]. "off end"
- object isInMemory ifTrue: [
- (object isKindOf: HashedCollection) ifTrue: [hashedCollections add: object].
- (object isKindOf: ContextPart) ifTrue: [
- (inSeg and: [object hasInstVarRef]) ifTrue: [
- receiverClasses add: object receiver class]].
- inSeg ifTrue: [
- (noStartUpNeeded includes: object class) ifFalse: [
- cls := object class.
- (msg := startUps at: cls ifAbsent: [nil]) ifNil: [
- msg := cls startUpFrom: self. "a Message, if we need to swap bytes this time"
- msg ifNil: [noStartUpNeeded add: cls]
- ifNotNil: [startUps at: cls put: msg]].
- msg ifNotNil: [msg sentTo: object]]]].
- object == 0] whileFalse.
  hashedCollections do: [ :each | each compact ]. "our purpose"
+ ^ receiverClasses "our secondary job"!
- ^ receiverClasses "our secondary job"
- !

Item was changed:
  ----- Method: ImageSegment>>revert (in category 'read/write segment') -----
  revert
  "Pretend this segment was never brought in.  Check that it has a fileName.  Replace (using become:) all the original roots of a segment with segmentRootStubs.  Thus the original objects will be reclaimed, and the root stubs will remain to bring the segment back in if it is needed.
  How to use revert:  In the project, choose 'save for reverting'.
 
  ReEnter the project.  Make changes.
  Either exit normally, and change will be kept, or
  Choose 'Revert to saved version'."
 
  fileName ifNil: [^ self].
  (state = #inactive) | (state = #onFile) ifFalse: [^ self].
  Cursor write showWhile: [
  arrayOfRoots elementsForwardIdentityTo:
  (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]).
  state := #onFile.
+ segment := nil]
- segment := nil.
- endMarker := nil].
 
  "Old version:
  How to use revert:  In the project, execute
  (Project current projectParameters at: #frozen put: true)
  Leave the project.  Check that the project went out to disk (it is gray in the Jump to Project list).
  ReEnter the project.  Hear a plink as it comes in from disk.  Make a change.
  Exit the project.  Choose 'Revert to previous version' in the dialog box.
  Check that the project went out to disk (it is gray in the Jump to Project list).
+ ReEnter the project and see that it is in the original state."!
- ReEnter the project and see that it is in the original state."
-
- !

Item was changed:
  ----- Method: ImageSegment>>verify:matches:knowing: (in category 'testing') -----
  verify: ob1 matches: ob2 knowing: matchDict
 
  | priorMatch first |
  ob1 == ob2 ifTrue:
+ ["If two pointers are same, they must be immediates or in outPointers"
+ (ob1 class isImmediateClass and: [ob1 = ob2]) ifTrue: [^self].
- ["If two pointers are same, they must be ints or in outPointers"
- ((ob1 isMemberOf: SmallInteger) and: [ob1 = ob2]) ifTrue: [^ self].
- ((ob1 isKindOf: Behavior) and: [ob1 indexIfCompact = ob2 indexIfCompact]) ifTrue: [^ self].
  (outPointers includes: ob1) ifTrue: [^ self].
  self halt].
  priorMatch := matchDict at: ob1 ifAbsent: [nil].
  priorMatch == nil
  ifTrue: [matchDict at: ob1 put: ob2]
  ifFalse: [priorMatch == ob2
  ifTrue: [^ self]
  ifFalse: [self halt]].
  self verify: ob1 class matches: ob2 class knowing: matchDict.
  ob1 class isVariable ifTrue:
  [ob1 basicSize = ob2 basicSize ifFalse: [self halt].
  first := 1.
+ ob1 isCompiledMethod ifTrue: [first := ob1 initialPC].
- (ob1 isMemberOf: CompiledMethod) ifTrue: [first := ob1 initialPC].
  first to: ob1 basicSize do:
  [:i | self verify: (ob1 basicAt: i) matches: (ob2 basicAt: i) knowing: matchDict]].
  ob1 class instSize = ob2 class instSize ifFalse: [self halt].
  1 to: ob1 class instSize do:
  [:i | self verify: (ob1 instVarAt: i) matches: (ob2 instVarAt: i) knowing: matchDict].
+ ob1 isCompiledMethod ifTrue:
- (ob1 isMemberOf: CompiledMethod) ifTrue:
  [ob1 header = ob2 header ifFalse: [self halt].
  ob1 numLiterals = ob2 numLiterals ifFalse: [self halt].
  1 to: ob1 numLiterals do:
  [:i | self verify: (ob1 literalAt: i) matches: (ob2 literalAt: i) knowing: matchDict]]!

Item was changed:
  ----- Method: ImageSegment>>writeForExport: (in category 'read/write segment') -----
  writeForExport: shortName
  "Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk."
 
+ | fileStream |
- | fileStream temp |
  state = #activeCopy ifFalse: [self error: 'wrong state'].
- temp := endMarker.
- endMarker := nil.
  fileStream := FileStream newFileNamed: (FileDirectory fileName: shortName extension: self class fileExtension).
  fileStream fileOutClass: nil andObject: self.
+ "remember extra structures.  Note class names."!
- "remember extra structures.  Note class names."
- endMarker := temp.
- !

Item was changed:
  ----- Method: ImageSegment>>writeForExportWithSources:inDirectory: (in category 'read/write segment') -----
  writeForExportWithSources: fName inDirectory: aDirectory
  "Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk.  Append the source code of any classes in roots.  Target system will quickly transfer the sources to its changes file."
 
  "this is the old version which I restored until I solve the gzip problem"
 
+ | fileStream tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource |
- | fileStream temp tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource |
  state = #activeCopy ifFalse: [self error: 'wrong state'].
  (fName includes: $.) ifFalse: [
  ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.].
- temp := endMarker.
- endMarker := nil.
  tempFileName := aDirectory nextNameFor: 'SqProject' extension: 'temp'.
  zipper := [
  ProgressNotification signal: '3:uncompressedSaveComplete'.
  (aDirectory oldFileNamed: tempFileName) compressFile. "makes xxx.gz"
  aDirectory
  rename: (tempFileName, FileDirectory dot, 'gz')
  toBe: fName.
  aDirectory
  deleteFileNamed: tempFileName
  ifAbsent: []
  ].
  fileStream := aDirectory newFileNamed: tempFileName.
  fileStream fileOutClass: nil andObject: self.
  "remember extra structures.  Note class names."
- endMarker := temp.
 
  "append sources"
+ allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior].
- allClassesInRoots := arrayOfRoots select: [:cls | cls isKindOf: Behavior].
  classesToWriteEntirely := allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined].
  methodsWithSource := OrderedCollection new.
  allClassesInRoots do: [ :cls |
  (classesToWriteEntirely includes: cls) ifFalse: [
  cls selectorsAndMethodsDo: [ :sel :meth |
  meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}].
  ].
  ].
  ].
  (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self].
 
  fileStream reopen; setToEnd.
  fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs.
  methodsWithSource do: [ :each |
  fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:"
  fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ',
  each first name printString,' methodsFor: ',
  (each first organization categoryOfElement: each second) asString printString,
  ' stamp: ',(each third timeStamp) printString; cr.
  fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString.
  fileStream nextChunkPut: ' '; cr.
  ].
  classesToWriteEntirely do: [:cls |
  cls isMeta ifFalse: [fileStream nextPutAll:
  (cls name, ' category: ''', cls category, '''.!!'); cr; cr].
  cls organization
  putCommentOnFile: fileStream
  numbered: 0
  moveSource: false
  forClass: cls. "does nothing if metaclass"
  cls organization categories do:
  [:heading |
  cls fileOutCategory: heading
  on: fileStream
  moveSource: false
  toFile: 0]].
  "no class initialization -- it came in as a real object"
  fileStream close.
+ zipper value!
- zipper value.!

Item was changed:
  ----- Method: ImageSegment>>writeForExportWithSources:inDirectory:changeSet: (in category 'read/write segment') -----
  writeForExportWithSources: fName inDirectory: aDirectory changeSet:
  aChangeSetOrNil
  "Write the segment on the disk with all info needed to
  reconstruct it in a new image.  For export.  Out pointers are encoded
  as normal objects on the disk.  Append the source code of any classes
  in roots.  Target system will quickly transfer the sources to its
  changes file."
  "Files out a changeSet first, so that a project can contain
  classes that are unique to the project."
 
+ | fileStream tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource |
- | fileStream temp tempFileName zipper allClassesInRoots
- classesToWriteEntirely methodsWithSource |
  state = #activeCopy ifFalse: [self error: 'wrong state'].
  (fName includes: $.) ifFalse: [
  ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at
+ the end of the file name'].
- the end of the file name'.].
- temp := endMarker.
- endMarker := nil.
  tempFileName := aDirectory nextNameFor: 'SqProject' extension: 'temp'.
  zipper := [
  Preferences debugPrintSpaceLog ifTrue:[
  fileStream := aDirectory newFileNamed:
  (fName copyFrom: 1 to: (fName
  lastIndexOf: $.)), 'space'.
  self printSpaceAnalysisOn: fileStream.
  fileStream close].
  ProgressNotification signal: '3:uncompressedSaveComplete'.
  (aDirectory oldFileNamed: tempFileName) compressFile.
  "makes xxx.gz"
  aDirectory
  rename: (tempFileName, FileDirectory dot, 'gz')
  toBe: fName.
  aDirectory
  deleteFileNamed: tempFileName
  ifAbsent: []
  ].
  fileStream := aDirectory newFileNamed: tempFileName.
  fileStream fileOutChangeSet: aChangeSetOrNil andObject: self.
  "remember extra structures.  Note class names."
- endMarker := temp.
 
  "append sources"
+ allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior].
- allClassesInRoots := arrayOfRoots select: [:cls | cls
- isKindOf: Behavior].
  classesToWriteEntirely := allClassesInRoots select: [ :cls |
+ cls theNonMetaClass isSystemDefined].
- cls theNonMetaClass isSystemDefined].
  methodsWithSource := OrderedCollection new.
  allClassesInRoots do: [ :cls |
  (classesToWriteEntirely includes: cls) ifFalse: [
  cls selectorsAndMethodsDo: [ :sel :meth |
  meth sourcePointer = 0 ifFalse:
+ [methodsWithSource add: {cls. sel. meth}].
- [methodsWithSource add: {cls. sel. meth}].
  ].
  ].
  ].
+ (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue:
+ [zipper value. ^ self].
- (classesToWriteEntirely isEmpty and: [methodsWithSource
- isEmpty]) ifTrue: [zipper value. ^ self].
 
  fileStream reopen; setToEnd.
  fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs.
  methodsWithSource do: [ :each |
  fileStream nextPut: $!!. "try to pacify
  ImageSegment>>scanFrom:"
  fileStream nextChunkPut: 'RenamedClassSourceReader
  formerClassName: ',
  each first name printString,' methodsFor: ',
  (each first organization
  categoryOfElement: each second) asString printString,
  ' stamp: ',(each third timeStamp) printString; cr.
  fileStream nextChunkPut: (each third getSourceFor:
  each second in: each first) asString.
  fileStream nextChunkPut: ' '; cr.
  ].
  classesToWriteEntirely do: [:cls |
  cls isMeta ifFalse: [fileStream nextPutAll:
  (cls name, '
  category: ''', cls category, '''.!!'); cr; cr].
  cls organization
  putCommentOnFile: fileStream
  numbered: 0
  moveSource: false
  forClass: cls. "does nothing if metaclass"
  cls organization categories do:
  [:heading |
  cls fileOutCategory: heading
  on: fileStream
  moveSource: false
  toFile: 0]].
  "no class initialization -- it came in as a real object"
  fileStream close.
+ zipper value
- zipper value.
  !

Item was changed:
  ----- Method: ImageSegment>>writeForExportWithSourcesGZ:inDirectory: (in category 'read/write segment') -----
  writeForExportWithSourcesGZ: fName inDirectory: aDirectory
  "Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk.  Append the source code of any classes in roots.  Target system will quickly transfer the sources to its changes file."
 
  "this is the gzipped version which I have temporarily suspended until I can get resolve the problem with forward references tring to reposition the stream - RAA 11 june 2000"
 
 
 
 
+ | fileStream allClassesInRoots classesToWriteEntirely methodsWithSource |
- | fileStream temp allClassesInRoots classesToWriteEntirely methodsWithSource |
  state = #activeCopy ifFalse: [self error: 'wrong state'].
  (fName includes: $.) ifFalse: [
  ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.].
- temp := endMarker.
- endMarker := nil.
  fileStream := GZipSurrogateStream newFileNamed: fName inDirectory: aDirectory.
  fileStream fileOutClass: nil andObject: self.
  "remember extra structures.  Note class names."
- endMarker := temp.
 
  "append sources"
+ allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior].
- allClassesInRoots := arrayOfRoots select: [:cls | cls isKindOf: Behavior].
  classesToWriteEntirely := allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined].
  methodsWithSource := OrderedCollection new.
  allClassesInRoots do: [ :cls |
  (classesToWriteEntirely includes: cls) ifFalse: [
  cls selectorsAndMethodsDo: [ :sel :meth |
  meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}].
  ].
  ].
  ].
  (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [
  fileStream reallyClose. "since #close is ignored"
  ^ self
  ].
  "fileStream reopen; setToEnd." "<--not required with gzipped surrogate stream"
  fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs.
  methodsWithSource do: [ :each |
  fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:"
  fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ',
  each first name printString,' methodsFor: ',
  (each first organization categoryOfElement: each second) asString printString,
  ' stamp: ',(each third timeStamp) printString; cr.
  fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString.
  fileStream nextChunkPut: ' '; cr.
  ].
  classesToWriteEntirely do: [:cls |
  cls isMeta ifFalse: [fileStream nextPutAll:
  (cls name, ' category: ''', cls category, '''.!!'); cr; cr].
  cls organization
  putCommentOnFile: fileStream
  numbered: 0
  moveSource: false
  forClass: cls. "does nothing if metaclass"
  cls organization categories do:
  [:heading |
  cls fileOutCategory: heading
  on: fileStream
  moveSource: false
  toFile: 0]].
  "no class initialization -- it came in as a real object"
+ fileStream reallyClose "since #close is ignored"
- fileStream reallyClose. "since #close is ignored"
  !

Item was changed:
  ----- Method: ImageSegment>>writeToFile (in category 'read/write segment') -----
  writeToFile
 
  state = #active ifFalse: [self error: 'wrong state'. ^ self].
  Cursor write showWhile: [
  segmentName ifNil: [
  segmentName := (FileDirectory localNameFor: fileName) sansPeriodSuffix].
  "OK that still has number on end.  This is an unusual case"
  fileName := self class uniqueFileNameFor: segmentName. "local name"
  (self class segmentDirectory newFileNamed: fileName) nextPutAll: segment; close.
  segment := nil.
- endMarker := nil.
  state := #onFile].!