Bert Freudenberg uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-bf.916.mcz
==================== Summary ====================
Name: System-bf.916 Author: bf Time: 14 September 2016, 3:44:50.062121 pm UUID: aeafedd5-da52-4801-a48b-d5bb2fd288cc Ancestors: System-bf.915
Replace VM-level ImageSegment loading with a Smalltalk implementation for old (interpreter-era) projects.
Also removes support for writing segments.
This overrides the Spur support introduced in System-eem.758.
=============== Diff against System-bf.915 ===============
Item was changed: Object subclass: #ImageSegment instanceVariableNames: 'arrayOfRoots segment outPointers state segmentName fileName userRootCnt renamedClasses' + classVariableNames: 'RecentlyRenamedClasses' - classVariableNames: 'BiggestFileNumber RecentlyRenamedClasses' poolDictionaries: '' category: 'System-Object Storage'!
+ !ImageSegment commentStamp: 'bf 9/14/2016 13:42' prior: 0! + ImageSegment is used to import old (interpreter VM era) projects + into new images. Instead of a VM primitive it uses ImageSegmentLoader + to load objects from the segment. All methods for writing have been removed. + + The original ImageSegment used an "endMarker" object to enumerate + all objects in the segment, relying on the fact that all objects were layed + out continuously in object memory and could be traversed via #nextObject. + Since Spur makes no such guarantees the endMarker instance var has been + removed, instead the segment is converted into an Array of all objects, + so they can be enumerated. + + --- Original class comment --- - !ImageSegment commentStamp: 'eem 8/21/2015 18:55' 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' 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 := - 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 removed: - ----- Method: ImageSegment class>>activeClasses (in category 'testing') ----- - activeClasses "ImageSegment activeClasses" - "Restore all remaining MD faults and return the active classes" - - | unused active | - unused := OrderedCollection new. - active := OrderedCollection new. - Smalltalk allClasses do: - [:c | (c instVarNamed: 'methodDict') - ifNil: [unused addLast: c] - ifNotNil: [active addLast: c]]. - unused do: [:c | c recoverFromMDFault]. - ^ active - !
Item was removed: - ----- Method: ImageSegment class>>activeClassesByCategory (in category 'testing') ----- - activeClassesByCategory "ImageSegment activeClassesByCategory" - "Return a dictionary of active classes by system category. - Useful for finding kernel categories to minimize swapping." - - | active dict | - active := self activeClasses. - dict := Dictionary new. - active do: - [:c | | cat list | cat := c category. - list := dict at: cat ifAbsent: [Array new]. - dict at: cat put: (list copyWith: c)]. - ^ dict - " - ImageSegment discoverActiveClasses <-- do it - -- do something typical -- - ImageSegment activeClassesByCategory <-- inspect it - "!
Item was removed: - ----- Method: ImageSegment class>>compressedFileExtension (in category 'accessing') ----- - compressedFileExtension - ^'sqz'!
Item was removed: - ----- Method: ImageSegment class>>discoverActiveClasses (in category 'testing') ----- - discoverActiveClasses "ImageSegment discoverActiveClasses" - "Run this method, do a few things, maybe save and resume the image. - This will leave unused classes with MDFaults. - You MUST follow this soon by activeClasses, or by swapOutInactiveClasses." - - "NOTE: discoverActiveClasses uses Squeak's ability to detect and recover from faults due to a nil method dictionary. It staches the method dict in with the organization during the time when discovery is in progress (Gag me with a spoon). This is why the faults need to be cleared promptly before resuming normal work with the system. It is also important that classes *do not* refer directly to their method dictionary, but only via the accessor message." - - Smalltalk allClasses do: - [:c | | ok | ok := true. - #(Array Object Class Message MethodDictionary) do: - [:n | ((Smalltalk at: n) == c or: - [(Smalltalk at: n) inheritsFrom: c]) ifTrue: [ok := false]]. - ok ifTrue: [c induceMDFault]]. - " - ImageSegment discoverActiveClasses. - -- do something typical -- - PopUpMenu notify: ImageSegment activeClasses size printString , ' classes were active out of ' , - Smalltalk allClasses size printString. - "!
Item was removed: - ----- Method: ImageSegment class>>fileExtension (in category 'accessing') ----- - fileExtension - ^'extSeg'!
Item was removed: - ----- Method: ImageSegment class>>folder (in category 'fileIn/Out') ----- - folder - | im | - "Full path name of segments folder. Be sure to duplicate and rename the folder when you duplicate and rename an image. Is $_ legal in all file systems?" - - im := Smalltalk imageName. - ^ (im copyFrom: 1 to: im size - 6 "'.image' size"), '_segs'!
Item was removed: - ----- Method: ImageSegment class>>reclaimObsoleteSegmentFiles (in category 'fileIn/Out') ----- - reclaimObsoleteSegmentFiles "ImageSegment reclaimObsoleteSegmentFiles" - "Delete segment files that can't be used after this image is saved. - Note that this is never necessary -- it just saves file space." - - | segDir segFiles folderName byName exists | - folderName := FileDirectory default class localNameFor: self folder. - (FileDirectory default includesKey: folderName) ifFalse: [ - ^ self "don't create if absent"]. - segDir := self segmentDirectory. - segFiles := (segDir fileNames select: [:fn | fn endsWith: '.seg']) asSet. - exists := segFiles copy. - segFiles isEmpty ifTrue: [^ self]. - byName := Set new. - "Remove (save) every file owned by a segment in memory" - ImageSegment allInstancesDo: [:is | | aFileName | - (aFileName := is localName) ifNotNil: [ - segFiles remove: aFileName ifAbsent: []. - (exists includes: aFileName) ifFalse: [ - Transcript cr; show: 'Segment file not found: ', aFileName]. - byName add: is segmentName]]. - "Of the segments we have seen, delete unclaimed the files." - segFiles do: [:fName | - "Delete other file versions with same project name as one known to us" - (byName includes: (fName sansPeriodSuffix stemAndNumericSuffix first)) - ifTrue: [segDir deleteFileNamed: fName]].!
Item was removed: - ----- Method: ImageSegment class>>segmentDirectory (in category 'fileIn/Out') ----- - segmentDirectory - "Return a directory object for the folder of segments. - Create such a folder if none exists." - | dir folderName | - dir := FileDirectory default. - folderName := dir class localNameFor: self folder. "imageName:=segs" - (dir includesKey: folderName) ifFalse: - [dir createDirectory: folderName]. "create the folder if necess" - ^ dir directoryNamed: folderName!
Item was removed: - ----- Method: ImageSegment class>>shutDown (in category 'fileIn/Out') ----- - shutDown - "Delete segment files that can't be used after this image is saved." - - "This is Optional. - (1) How tell if saving image now? Only do if is. - (2) ImageSegmentRootStub allInstancesDo: - If more than one file, delete all but one we are using now. - Leave files with not stubs (could be out in a segment) - Must forbid two projects from having the same name!! - (3) all Projects do: - If project is in, delete all files with its name. - " - !
Item was removed: - ----- Method: ImageSegment class>>startUp (in category 'fileIn/Out') ----- - startUp - | choice | - "Minimal thing to assure that a .segs folder is present" - - (Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [ - (FileDirectory default includesKey: (FileDirectory localNameFor: self folder)) - ifFalse: [ - choice := UIManager default - chooseFrom: #('Create folder' 'Quit without saving') - title: - 'The folder with segments for this image is missing.' withCRs, - self folder, '\If you have moved or renamed the image file,' withCRs, - 'please Quit and rename the segments folder in the same way'. - choice = 1 ifTrue: [FileDirectory default createDirectory: self folder]. - choice = 2 ifTrue: [Smalltalk snapshot: false andQuit: true]]] - - !
Item was removed: - ----- Method: ImageSegment class>>swapOutInactiveClasses (in category 'testing') ----- - swapOutInactiveClasses "ImageSegment swapOutInactiveClasses" - "Make up segments by grouping unused classes by system category. - Read about, and execute discoverActiveClasses, and THEN execute this one." - - | unused groups | - ImageSegment recoverFromMDFault. - ImageSegmentRootStub recoverFromMDFault. - unused := Smalltalk allClasses select: [:c | (c instVarNamed: 'methodDict') == nil]. - unused do: [:c | c recoverFromMDFault]. - groups := Dictionary new. - SystemOrganization categories do: - [:cat | | i | - i := (cat findLast: [:c | c = $-]) - 1. - i <= 0 ifTrue: [i := cat size]. - groups at: (cat copyFrom: 1 to: i) - put: (groups at: (cat copyFrom: 1 to: i) ifAbsent: [Array new]) , - ((SystemOrganization superclassOrder: cat) select: [:c | - unused includes: c]) asArray]. - groups keys do: - [:cat | | roots | roots := groups at: cat. - Transcript cr; cr; show: cat; cr; print: roots; endEntry. - roots := roots , (roots collect: [:c | c class]). - (cat beginsWith: 'Sys' "something here breaks") ifFalse: - [(ImageSegment new copyFromRoots: roots sizeHint: 0) extract; - writeToFile: cat]. - Transcript cr; print: Smalltalk garbageCollect; endEntry]!
Item was removed: - ----- Method: ImageSegment class>>swapOutProjects (in category 'testing') ----- - swapOutProjects "ImageSegment swapOutProjects" - "Swap out segments for all projects other than the current one." - - | spaceLeft | - spaceLeft := Smalltalk garbageCollect. - Project allProjects doWithIndex: - [:p :i | | newSpaceLeft | p couldBeSwappedOut ifTrue: - [Transcript cr; cr; nextPutAll: p name. - (ImageSegment new copyFromRoots: (Array with: p) sizeHint: 0) - extract; writeToFile: 'project' , i printString. - newSpaceLeft := Smalltalk garbageCollect. - Transcript cr; print: newSpaceLeft - spaceLeft; endEntry. - spaceLeft := newSpaceLeft]].!
Item was removed: - ----- Method: ImageSegment class>>testClassFaultOn: (in category 'testing') ----- - testClassFaultOn: someClass "ImageSegment testClassFaultOn: FileList" - "Swap out a class with an existing instance. Then send a message to the inst. - This will cause the VM to choke down deep and resend #cannotInterpret:. - This in turn will send a message to the stubbed class which will choke - and resend: #doesNotUnderstand:. Then, if we're lucky, things will start working." - - (ImageSegment new copyFromRoots: (Array with: someClass with: someClass class) - sizeHint: 0) extract; writeToFile: 'test'. - !
Item was removed: - ----- Method: ImageSegment class>>uniqueFileNameFor: (in category 'fileIn/Out') ----- - uniqueFileNameFor: segName - "Choose a unique file name for the segment with this name." - | segDir fileName listOfFiles | - segDir := self segmentDirectory. - listOfFiles := segDir fileNames. - BiggestFileNumber ifNil: [BiggestFileNumber := 1]. - BiggestFileNumber > 99 ifTrue: [BiggestFileNumber := 1]. "wrap" - [fileName := segName, BiggestFileNumber printString, '.seg'. - (listOfFiles includes: fileName)] whileTrue: [ - BiggestFileNumber := BiggestFileNumber + 1]. "force a unique file name" - ^ fileName!
Item was removed: - ----- Method: ImageSegment>>aComment (in category 'compact classes') ----- - aComment - "Compact classes are a potential problem because a pointer to the class would not ordinarily show up in the outPointers. We add the classes of all compact classes to outPointers, both for local and export segments. - Compact classes are never allowed as roots. No compact class may be in an Environment that is written out to disk. (In local segments, the compact classes array should never have an ImageSegmentRootStub in it. For export, fileIn the class first, then load a segment with instances of it. The fileIn code can be pasted onto the front of the .extSeg file) - For local segments, a class may become compact while its instances are out on the disk. Or it may become un-compact. A compact class may change shape while some of its instances are on disk. All three cases go through (ClassDescription updateInstancesFrom:). If it can't rule out an instance being in the segment, it reads it in to fix the instances. - See Behavior.becomeCompact for the rules on Compact classes. Indexes may not be reused. This is so that an incoming export segment has its index available. (Changes may be needed in the way indexes are assigned.) - For export segments, a compact class may have a different shape. The normal class reshape mechanism will catch this. During the installation of the segment, objects will have the wrong version of their class momentarily. We will change them back before we get caught. - For export segments, the last two items in outPointers are the number 1717 and an array of the compact classes used in this segment. (The classes in the array are converted from DiskProxies by SmartRefStream.) If that class is not compact in the new image, the instances are recopied. - "!
Item was removed: - ----- 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 removed: - ----- Method: ImageSegment>>allInstancesOf:do: (in category 'instance change shape') ----- - allInstancesOf: aClass do: aBlock - | withSymbols oldInstances segSize | - "Bring me in, locate instances of aClass and submit them to the block. Write me out again." - - (state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self]. - withSymbols := state = #onFileWithSymbols. - (outPointers includes: aClass) ifFalse: [^ self]. - "If has instances, they point out at the class" - state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]]. - segSize := segment size. - self install. - oldInstances := OrderedCollection new. - self allObjectsDo: [:obj | obj class == aClass ifTrue: [ - oldInstances add: obj]]. - oldInstances do: aBlock. "do the work" - self copyFromRoots: arrayOfRoots sizeHint: segSize. - self extract. - withSymbols - ifTrue: [self writeToFileWithSymbols] - ifFalse: [self writeToFile]. - - !
Item was changed: ----- 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 class isPointers ifTrue: [^self]. "ok" - 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 removed: - ----- Method: ImageSegment>>classNameAt: (in category 'statistics') ----- - classNameAt: index - | ccIndex | - ccIndex := self compactIndexAt: index. - ccIndex = 0 ifFalse:[^(Smalltalk compactClassesArray at: ccIndex) name]. - ccIndex := segment at: index-1. - (ccIndex bitAnd: 16r80000000) = 0 ifTrue:[ - "within segment; likely a user object" - ^#UserObject]. - ccIndex := (ccIndex bitAnd: 16r7FFFFFFF) bitShift: -2. - ^(outPointers at: ccIndex) name!
Item was changed: + ----- Method: ImageSegment>>comeFullyUpOnReload: (in category 'fileIn') ----- - ----- 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 existing forgetDoItsClass endianness | - | mapFakeClassesToReal receiverClasses rootsToUnhiberhate myProject forgetDoItsClasses endianness |
+ forgetDoItsClass := Set new. - 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." self fixCapitalizationOfSymbols. + endianness := (segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]. + segment := ImageSegmentLoader new loadSegmentFrom: segment outPointers: outPointers. + arrayOfRoots := segment first. - endianness := self endianness. - 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 | - 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 isMemberOf: TTCFontSet) ifTrue: [ + existing := TTCFontSet familyName: importedObject familyName + pointSize: importedObject pointSize. "supplies default" - (importedObject isKindOf: TTCFontSet) ifTrue: [ - 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: endianness ~~ Smalltalk endianness. "rehash sets" - 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. - importedObject class class == Metaclass ifTrue: [ - forgetDoItsClasses add: importedObject. - self declare: importedObject]]. 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: [ - importedObject isCompiledMethod ifTrue: [ - importedObject sourcePointer > 0 ifTrue: [importedObject zapSourcePointer]]. - (importedObject isKindOf: Project) ifTrue: [ myProject := importedObject. importedObject ensureChangeSetNameUnique. Project addingProject: importedObject. importedObject restoreReferences. + self dependentsRestore: importedObject. + ScriptEditorMorph writingUniversalTiles: + ((importedObject projectPreferenceAt: #universalTiles) ifNil: [false])]]. - 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 removeFromSystemUnlogged. + aFake becomeForward: aReal]. - "do not assign the fake's hash to the real class" - aFake becomeForward: aReal copyHash: false]. SystemOrganization removeEmptyCategories]. + forgetDoItsClass do: [:c | c forgetDoIts]. - forgetDoItsClasses do: [:c | c forgetDoIts]. "^ self" !
Item was removed: - ----- Method: ImageSegment>>compactClassesArray (in category 'compact classes') ----- - compactClassesArray - | ccIndexes ind ccArray hdrBits | - "A copy of the real compactClassesArray, but with only the classes actually used in the segment. Slow, but OK for export." - - ccIndexes := Set new. - ind := 2. "skip version word, first object" - "go past extra header words" - (hdrBits := (segment atPin: ind) bitAnd: 3) = 1 ifTrue: [ind := ind+1]. - hdrBits = 0 ifTrue: [ind := ind+2]. - - [ccIndexes add: (self compactIndexAt: ind). "0 if has class field" - ind := self objectAfter: ind. - ind > segment size] whileFalse. - ccArray := Smalltalk compactClassesArray clone. - 1 to: ccArray size do: [:ii | "only the ones we use" - (ccIndexes includes: ii) ifFalse: [ccArray at: ii put: nil]]. - ^ ccArray!
Item was removed: - ----- Method: ImageSegment>>compactIndexAt: (in category 'compact classes') ----- - compactIndexAt: ind - | word | - "Look in this header word in the segment and find it's compact class index. *** Warning: When class ObjectMemory change, be sure to change it here. *** " - - ((word := segment at: ind) bitAnd: 3) = 2 ifTrue: [^ 0]. "free block" - ^ (word >> 12) bitAnd: 16r1F "Compact Class field of header word" - - !
Item was removed: - ----- Method: ImageSegment>>copyFromRoots:sizeHint: (in category 'read/write segment') ----- - copyFromRoots: aRootArray sizeHint: segSizeHint - "Copy a tree of objects into a WordArray segment. The copied objects in the segment are not in the normal Squeak space. 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.) - Caller must hold onto Symbols. - To go faster, make sure objects are not repeated in aRootArray and other method directly, with true." - - self copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: false - !
Item was removed: - ----- 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]. - 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 - !
Item was removed: - ----- Method: ImageSegment>>copyFromRootsForExport: (in category 'read/write segment') ----- - copyFromRootsForExport: rootArray - "When possible, use copySmartRootsExport:. This way may not copy a complete tree of objects. Add to roots: all of the methods pointed to from the outside by blocks." - | newRoots list segSize symbolHolder | - arrayOfRoots := rootArray. - "self halt." - symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers, - so they will be in outPointers" - (newRoots := self rootsIncludingPlayers) ifNotNil: [ - arrayOfRoots := newRoots]. "world, presenter, and all Player classes" - "Creation of the segment happens here" - self copyFromRoots: arrayOfRoots sizeHint: 0. - segSize := segment size. - [(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [ - arrayOfRoots := newRoots. - self copyFromRoots: arrayOfRoots sizeHint: segSize]. - "with methods pointed at from outside" - [(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [ - arrayOfRoots := newRoots. - self copyFromRoots: arrayOfRoots sizeHint: segSize]. - "with methods, blocks from outPointers" - "classes of receivers of blocks" - list := self compactClassesArray. - outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). - "Zap sender of a homeContext. Can't send live stacks out." - 1 to: outPointers size do: [:ii | - (outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil]. - (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]]. - symbolHolder.!
Item was removed: - ----- Method: ImageSegment>>copyFromRootsLocalFileFor:sizeHint: (in category 'read/write segment') ----- - copyFromRootsLocalFileFor: rootArray sizeHint: segSize - "If the roots include a World, add its Player classes to the roots." - | newRoots | - - arrayOfRoots := rootArray. - [(newRoots := self rootsIncludingPlayers) == nil] whileFalse: [ - arrayOfRoots := newRoots]. "world, presenter, and all Player classes" - self copyFromRoots: arrayOfRoots sizeHint: segSize. - !
Item was removed: - ----- Method: ImageSegment>>copySmartRootsExport: (in category 'read/write segment') ----- - copySmartRootsExport: rootArray - "Use SmartRefStream to find the object. Make them all roots. Create the segment in memory. Project should be in first five objects in rootArray." - | newRoots list segSize symbolHolder replacements naughtyBlocks allClasses sizeHint proj dummy | - - "self halt." - symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers, - so they will be in outPointers" - - dummy := ReferenceStream on: (DummyStream on: nil). - "Write to a fake Stream, not a file" - "Collect all objects" - dummy insideASegment: true. "So Uniclasses will be traced" - dummy rootObject: rootArray. "inform him about the root" - dummy nextPut: rootArray. - (proj :=dummy project) ifNotNil: [self dependentsSave: dummy]. - allClasses := SmartRefStream new uniClassInstVarsRefs: dummy. - "catalog the extra objects in UniClass inst vars. Put into dummy" - allClasses do: [:cls | - dummy references at: cls class put: false. "put Player5 class in roots" - dummy blockers removeKey: cls class ifAbsent: []]. - "refs := dummy references." - arrayOfRoots := self smartFillRoots: dummy. "guaranteed none repeat" - self savePlayerReferences: dummy references. "for shared References table" - replacements := dummy blockers. - dummy project "recompute it" ifNil: [self error: 'lost the project!!']. - dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project']. - dummy := nil. "force GC?" - naughtyBlocks := arrayOfRoots select: [ :each | - (each isKindOf: ContextPart) and: [each hasInstVarRef] - ]. - - "since the caller switched ActiveWorld, put the real one back temporarily" - naughtyBlocks isEmpty ifFalse: [ - World becomeActiveDuring: [World firstHand becomeActiveDuring: [ | goodToGo | - goodToGo := (UIManager default - chooseFrom: #('keep going' 'stop and take a look') - title: - 'Some block(s) which reference instance variables - are included in this segment. These may fail when - the segment is loaded if the class has been reshaped. - What would you like to do?') = 1. - goodToGo ifFalse: [ - naughtyBlocks inspect. - self error: 'Here are the bad blocks']. - ]]. - ]. - "Creation of the segment happens here" - - "try using one-quarter of memory min: four megs to publish (will get bumped later)" - sizeHint := (Smalltalk garbageCollect // 4 // 4) min: 1024*1024. - self copyFromRoots: arrayOfRoots sizeHint: sizeHint areUnique: true. - segSize := segment size. - [(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [ - arrayOfRoots := newRoots. - self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. - "with methods pointed at from outside" - [(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [ - arrayOfRoots := newRoots. - self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. - "with methods, blocks from outPointers" - list := self compactClassesArray. - outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). - 1 to: outPointers size do: [:ii | - (outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil]. - (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]. - "substitute new object in outPointers" - (replacements includesKey: (outPointers at: ii)) ifTrue: [ - outPointers at: ii put: (replacements at: (outPointers at: ii))]]. - proj ifNotNil: [self dependentsCancel: proj]. - symbolHolder.!
Item was changed: + ----- Method: ImageSegment>>declare: (in category 'fileIn') ----- - ----- Method: ImageSegment>>declare: (in category 'fileIn/Out') ----- declare: classThatIsARoot
| nameOnArrival | "The class just arrived in this segment. How fit it into the Smalltalk dictionary? If it had an association, that was installed with associationDeclareAt:."
nameOnArrival := classThatIsARoot name. + [self declareAndPossiblyRename: classThatIsARoot] + on: AttemptToWriteReadOnlyGlobal do: [:ex | ex resume: true]. - self declareAndPossiblyRename: classThatIsARoot. nameOnArrival == classThatIsARoot name ifTrue: [^self]. renamedClasses ifNil: [RecentlyRenamedClasses := renamedClasses := Dictionary new]. renamedClasses at: nameOnArrival put: classThatIsARoot name.
!
Item was changed: + ----- Method: ImageSegment>>declareAndPossiblyRename: (in category 'fileIn') ----- - ----- Method: ImageSegment>>declareAndPossiblyRename: (in category 'fileIn/Out') ----- declareAndPossiblyRename: classThatIsARoot | existing catInstaller | "The class just arrived in this segment. How fit it into the Smalltalk dictionary? If it had an association, that was installed with associationDeclareAt:."
catInstaller := [ classThatIsARoot superclass name == #Player ifTrue: [classThatIsARoot category: Object categoryForUniclasses] ifFalse: [(classThatIsARoot superclass name beginsWith: 'WonderLandActor') ifTrue: [classThatIsARoot category: 'Balloon3D-UserObjects'] ifFalse: [classThatIsARoot category: Object categoryForUniclasses]]. ]. classThatIsARoot superclass addSubclass: classThatIsARoot. (Smalltalk includesKey: classThatIsARoot name) ifFalse: [ "Class entry in Smalltalk not referred to in Segment, install anyway." catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. existing := Smalltalk at: classThatIsARoot name. existing xxxClass == ImageSegmentRootStub ifTrue: [ "We are that segment!! Must ask it carefully!!" catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. existing == false | (existing == nil) ifTrue: [ "association is in outPointers, just installed" catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. "Conflict with existing global or copy of the class" (existing isKindOf: Class) ifTrue: [ classThatIsARoot isSystemDefined not ifTrue: [ "UniClass. give it a new name" classThatIsARoot setName: classThatIsARoot baseUniclass chooseUniqueClassName. catInstaller value. "must be after new name" ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. "Take the incoming one" self inform: 'Using newly arrived version of ', classThatIsARoot name. classThatIsARoot superclass removeSubclass: classThatIsARoot. "just in case" (Smalltalk at: classThatIsARoot name) becomeForward: classThatIsARoot. catInstaller value. ^ classThatIsARoot superclass addSubclass: classThatIsARoot]. self error: 'Name already in use by a non-class: ', classThatIsARoot name. !
Item was removed: - ----- Method: ImageSegment>>deepCopyTest: (in category 'testing') ----- - deepCopyTest: aRootArray - "ImageSegment new deepCopyTest: Morph withAllSubclasses asArray" - "Project allInstances do: - [:p | p == Project current ifFalse: - [Transcript cr; cr; nextPutAll: p name. - ImageSegment new deepCopyTest: (Array with: p)]]." - | t1 t2 copy | - t1 := Time millisecondsToRun: [self copyFromRoots: aRootArray sizeHint: 0]. - t2 := Time millisecondsToRun: [copy := self segmentCopy]. - Transcript cr; print: segment size * 4; nextPutAll: ' bytes stored with '; - print: outPointers size; show: ' outpointers in '; print: t1; show: 'ms.'. - Transcript cr; nextPutAll: 'Reconstructed in '; print: t2; show: 'ms.'. - ^ copy - " - Smalltalk allClasses do: - [:m | ImageSegment new deepCopyTest: (Array with: m with: m class)] - "!
Item was changed: + ----- Method: ImageSegment>>dependentsCancel: (in category 'fileIn') ----- - ----- Method: ImageSegment>>dependentsCancel: (in category 'read/write segment') ----- dependentsCancel: aProject "Erase the place we temporarily held the dependents of things in this project. So we don't carry them around forever."
aProject projectParameters removeKey: #GlobalDependentsInProject ifAbsent: []!
Item was changed: + ----- Method: ImageSegment>>dependentsRestore: (in category 'fileIn') ----- - ----- Method: ImageSegment>>dependentsRestore: (in category 'read/write segment') ----- dependentsRestore: aProject "Retrieve the list of dependents from the exporting system, hook them up, and erase the place we stored them."
| dict | dict := aProject projectParameterAt: #GlobalDependentsInProject. dict ifNil: [^ self]. dict associationsDo: [:assoc | assoc value do: [:dd | assoc key addDependent: dd]].
self dependentsCancel: aProject.!
Item was removed: - ----- Method: ImageSegment>>dependentsSave: (in category 'read/write segment') ----- - dependentsSave: dummy - "Object that have dependents are supposed to be instances of subclasses of Model. But, class Objects still provides 'Global Dependents', and some people still use them. When both the model and the dependent are in a project that is being saved, remember them, so we can hook them up when this project is loaded in." - - | dict proj | - proj := dummy project. - dict := Dictionary new. - DependentsFields associationsDo: [:assoc | | list | - (dummy references includesKey: assoc key) ifTrue: [ - list := assoc value select: [:dd | dummy references includesKey: dd]. - list size > 0 ifTrue: [dict at: assoc key put: list]]]. - - dict size > 0 ifTrue: [ - proj projectParameterAt: #GlobalDependentsInProject put: dict]. - !
Item was removed: - ----- Method: ImageSegment>>doSpaceAnalysis (in category 'statistics') ----- - doSpaceAnalysis - "Capture statistics about the IS and print the number of instances per class and space usage" - | index sz word hdrBits cc instCount instSpace | - state == #activeCopy ifFalse:[self errorWrongState]. - instCount := IdentityDictionary new. - instSpace := IdentityDictionary new. - index := 2. "skip version word, first object" - "go past extra header words" - hdrBits := (segment at: index) bitAnd: 3. - hdrBits = 1 ifTrue: [index := index+1]. - hdrBits = 0 ifTrue: [index := index+2]. - [index > segment size] whileFalse:[ - hdrBits := (word := segment at: index) bitAnd: 3. - hdrBits = 2 ifTrue:[sz := word bitAnd: 16rFFFFFFFC]. - hdrBits = 0 ifTrue:[sz := ((segment at: index-2) bitAnd: 16rFFFFFFFC) + 8]. - hdrBits = 1 ifTrue:[sz := (word bitAnd: "SizeMask" 252) + 4]. - hdrBits = 3 ifTrue:[sz := word bitAnd: "SizeMask" 252]. - hdrBits = 2 - ifTrue:[cc := #freeChunk] - ifFalse:[cc := self classNameAt: index]. - instCount at: cc put: (instCount at: cc ifAbsent:[0]) + 1. - instSpace at: cc put: (instSpace at: cc ifAbsent:[0]) + sz. - index := self objectAfter: index]. - ^{instCount. instSpace}!
Item was removed: - ----- 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 removed: - ----- Method: ImageSegment>>errorWrongState (in category 'testing') ----- - errorWrongState - - ^ self error: 'wrong state'!
Item was removed: - ----- Method: ImageSegment>>extract (in category 'read/write segment') ----- - extract - "This operation replaces (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." - - Cursor write showWhile: [ - state = #inactive ifTrue: [self copyFromRoots: arrayOfRoots sizeHint: 0]. - state = #activeCopy ifFalse: [self errorWrongState]. - arrayOfRoots elementsForwardIdentityTo: - (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]). - state := #active]. - !
Item was removed: - ----- Method: ImageSegment>>extractThenInstall (in category 'read/write segment') ----- - extractThenInstall - "For testing only" - - | newRoots | - state = #activeCopy ifFalse: [self errorWrongState]. - arrayOfRoots elementsForwardIdentityTo: - (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]). - state := #active. - newRoots := self loadSegmentFrom: segment outPointers: outPointers. - state := #inactive. - arrayOfRoots elementsForwardIdentityTo: newRoots. - !
Item was removed: - ----- Method: ImageSegment>>findInOut: (in category 'testing') ----- - findInOut: anArray - "Take an array of references to a morph, and try to classify them: in the segment, in outPointers, or other." - - String streamContents: [:strm | - anArray withIndexDo: [:obj :ind | - strm cr; nextPutAll: obj printString; space. - - ]].!
Item was removed: - ----- Method: ImageSegment>>findOwnerMap: (in category 'testing') ----- - findOwnerMap: morphs - | st | - "Construct a string that has a printout of the owner chain for every morph in the list. Need it as a string so not hold onto them." - - st := ''. - morphs do: [:mm | - (st includesSubstring: mm printString) ifFalse: [ - st := st, ' - ', mm allOwners printString]]. - Smalltalk at: #Owners put: st. - !
Item was removed: - ----- Method: ImageSegment>>findOwnersOutPtrs (in category 'testing') ----- - findOwnersOutPtrs - - | ow ff | - ow := Smalltalk at: #Owners ifAbsent: [^ self]. - ow ifNil: [^ self]. - outPointers do: [:oo | - oo isMorph ifTrue: [ - ow := ow copyReplaceAll: oo printString with: oo printString, '[<<<- Pointed at]']]. - ff := FileStream fileNamed: 'Owners log'. - ff nextPutAll: ow; close. - Smalltalk at: #Owners put: ow. - ff edit.!
Item was removed: - ----- Method: ImageSegment>>findRogueRootsAllMorphs: (in category 'testing') ----- - findRogueRootsAllMorphs: rootArray - "This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment. - 1) assemble all objects should be in seg: morph tree, presenter, scripts, player classes, metaclasses. Put in a Set. - 2) Remove the roots from this list. Ask for senders of each. Of the senders, forget the ones that are in the segment already. Keep others. The list is now all the 'incorrect' pointers into the segment." - - | inSeg testRoots scriptEditors pointIn wld xRoots | - Smalltalk garbageCollect. - inSeg := IdentitySet new: 200. - arrayOfRoots := rootArray. - (testRoots := self rootsIncludingPlayers) ifNil: [testRoots := rootArray]. - testRoots do: - [:obj | - (obj isKindOf: Project) - ifTrue: - [inSeg add: obj. - wld := obj world. - inSeg add: wld presenter]. - (obj isKindOf: Presenter) ifTrue: [inSeg add: obj]]. - xRoots := wld ifNil: [testRoots] ifNotNil: [testRoots , (Array with: wld)]. - xRoots do: - [:obj | - "root is a project" - - obj isMorph - ifTrue: - [obj allMorphs do: - [:mm | - inSeg add: mm. - mm player ifNotNil: [inSeg add: mm player]]. - obj isWorldMorph ifTrue: [inSeg add: obj presenter]]]. - scriptEditors := IdentitySet new. - inSeg do: - [:obj | - obj isPlayerLike - ifTrue: - [scriptEditors addAll: (obj class tileScriptNames - collect: [:nn | obj scriptEditorFor: nn])]]. - scriptEditors do: [:se | inSeg addAll: se allMorphs]. - testRoots do: [:each | inSeg remove: each ifAbsent: []]. - "want them to be pointed at from outside" - pointIn := IdentitySet new: 400. - inSeg do: [:ob | pointIn addAll: (Utilities pointersTo: ob except: inSeg)]. - testRoots do: [:each | pointIn remove: each ifAbsent: []]. - pointIn remove: inSeg array ifAbsent: []. - pointIn remove: pointIn array ifAbsent: []. - inSeg do: - [:obj | - obj isMorph - ifTrue: - [pointIn remove: (obj instVarAt: 3) - ifAbsent: - ["submorphs" - - ]. - "associations in extension" - pointIn remove: obj extension ifAbsent: []. - obj extension ifNotNil: - [obj extension otherProperties ifNotNil: - [obj extension otherProperties associationsDo: - [:ass | - pointIn remove: ass ifAbsent: [] - "*** and extension actorState" - "*** and ActorState instantiatedUserScriptsDictionary ScriptInstantiations"]]]]. - obj isPlayerLike - ifTrue: [obj class scripts values do: [:us | pointIn remove: us ifAbsent: []]]]. - "*** presenter playerlist" - self halt: 'Examine local variables pointIn and inSeg'. - ^pointIn!
Item was removed: - ----- Method: ImageSegment>>findRogueRootsImSeg: (in category 'testing') ----- - findRogueRootsImSeg: rootArray - "This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment. - 1) Break all owner pointers in submorphs and all scripts. - 2) Create the segment and look at outPointers. - 3) Remove those we expect. - 4) Remember to quit without saving -- the owner pointers are smashed." - - | newRoots suspects bag1 bag2 | - arrayOfRoots := rootArray. - [(newRoots := self rootsIncludingPlayers) == nil] whileFalse: [ - arrayOfRoots := newRoots]. "world, presenter, and all Player classes" - self findRogueRootsPrep. "and free that context!!" - Smalltalk garbageCollect. - self copyFromRoots: arrayOfRoots sizeHint: 0. - - suspects := outPointers select: [:oo | oo isMorph]. - suspects size > 0 ifTrue: [suspects inspect]. - bag1 := Bag new. bag2 := Bag new. - outPointers do: [:key | - (key isKindOf: Class) - ifTrue: [bag2 add: key class name] - ifFalse: [(#(Symbol Point Rectangle True False String Float Color Form ColorForm StrikeFont Metaclass UndefinedObject TranslucentColor) includes: key class name) - ifTrue: [bag2 add: key class name] - ifFalse: [bag1 add: key class name]]]. - "(bag sortedCounts) is the SortedCollection" - (StringHolder new contents: bag1 sortedCounts printString, ' - - ', bag2 sortedCounts printString) - openLabel: 'Objects pointed at by the outside'. - self halt: 'Examine local variables pointIn and inSeg'. - - "Use this in inspectors: - outPointers select: [:oo | oo class == <a Class>]. " - - !
Item was removed: - ----- Method: ImageSegment>>findRogueRootsPrep (in category 'testing') ----- - findRogueRootsPrep - "Part of the tool to track down unwanted pointers into the segment. Break all owner pointers in submorphs, scripts, and viewers in flaps." - - | wld players morphs | - wld := arrayOfRoots detect: [:obj | - obj isMorph ifTrue: [obj isWorldMorph] ifFalse: [false]] ifNone: [nil]. - wld ifNil: [wld := arrayOfRoots detect: [:obj | obj isMorph] - ifNone: [^ self error: 'can''t find a root morph']]. - morphs := IdentitySet new: 400. - wld allMorphsAndBookPagesInto: morphs. - players := wld presenter allExtantPlayers. "just the cached list" - players do: [:pp | | scriptEditors | - scriptEditors := pp class tileScriptNames collect: [:nn | - pp scriptEditorFor: nn]. - scriptEditors do: [:se | morphs addAll: se allMorphs]]. - wld submorphs do: [:mm | "non showing flaps" - (mm isKindOf: FlapTab) ifTrue: [ - mm referent allMorphsAndBookPagesInto: morphs]]. - morphs do: [:mm | "break the back pointers" - mm isInMemory ifTrue: [ - (mm respondsTo: #target) ifTrue: [ - mm nearestOwnerThat: [:ow | ow == mm target - ifTrue: [mm target: nil. true] - ifFalse: [false]]]. - (mm respondsTo: #arguments) ifTrue: [ - mm arguments do: [:arg | arg ifNotNil: [ - mm nearestOwnerThat: [:ow | ow == arg - ifTrue: [mm arguments at: (mm arguments indexOf: arg) put: nil. true] - ifFalse: [false]]]]]. - mm eventHandler ifNotNil: ["recipients point back up" - (morphs includesAllOf: (mm eventHandler allRecipients)) ifTrue: [ - mm eventHandler: nil]]. - "temporary, until using Model for PartsBin" - (mm isMorphicModel) ifTrue: [ - (mm model isMorphicModel) ifTrue: [ - mm model breakDependents]]. - (mm isTextMorph) ifTrue: [mm setContainer: nil]]]. - (Smalltalk includesKey: #Owners) ifTrue: [Smalltalk at: #Owners put: nil]. - "in case findOwnerMap: is commented out" - "self findOwnerMap: morphs." - morphs do: [:mm | "break the back pointers" - mm isInMemory ifTrue: [mm privateOwner: nil]]. - "more in extensions?" - - !
Item was removed: - ----- Method: ImageSegment>>findRogueRootsRefStrm: (in category 'testing') ----- - findRogueRootsRefStrm: rootArray - "This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment. - 1) assemble all objects that should be in the segment by using SmartReference Stream and a dummyReference Stream. Put in a Set. - 2) Remove the roots from this list. Ask for senders of each. Of the senders, forget the ones that are in the segment already. Keep others. The list is now all the 'incorrect' pointers into the segment." - - | goodInSeg inSeg pointIn dummy | - dummy := ReferenceStream on: (DummyStream on: nil). - "Write to a fake Stream, not a file" - rootArray do: - [:root | - dummy rootObject: root. "inform him about the root" - dummy nextPut: root]. - inSeg := dummy references keys asSet. - dummy := nil. - Smalltalk garbageCollect. "dump refs dictionary" - rootArray do: [:each | inSeg remove: each ifAbsent: []]. - "want them to be pointed at from outside" - pointIn := IdentitySet new: 500. - goodInSeg := IdentitySet new: 2000. - inSeg do: - [:obj | | ok | - ok := obj class isPointers. - obj class == Color ifTrue: [ok := false]. - obj class == TranslucentColor ifTrue: [ok := false]. - obj class == Array ifTrue: [obj size = 0 ifTrue: [ok := false]]. - "shared #() in submorphs of all Morphs" - ok ifTrue: [goodInSeg add: obj]]. - goodInSeg - do: [:ob | pointIn addAll: (Utilities pointersTo: ob except: #())]. - inSeg do: [:each | pointIn remove: each ifAbsent: []]. - rootArray do: [:each | pointIn remove: each ifAbsent: []]. - pointIn remove: inSeg array ifAbsent: []. - pointIn remove: goodInSeg array ifAbsent: []. - pointIn remove: pointIn array ifAbsent: []. - self halt: 'Examine local variables pointIn and inSeg'. - ^pointIn!
Item was removed: - ----- Method: ImageSegment>>findStacks (in category 'read/write segment') ----- - findStacks - "Return an array of all the StackMorphs in this project." - | guys stacks | - guys := IdentitySet new. - Smalltalk at: #StackMorph ifPresent:[:aClass| - guys addAll: aClass withAllSubclasses. - ]. - stacks := OrderedCollection new. - arrayOfRoots do: [:obj | - (guys includes: obj class) ifTrue: [stacks add: obj]]. - ^ stacks!
Item was changed: + ----- Method: ImageSegment>>fixCapitalizationOfSymbols (in category 'fileIn') ----- - ----- Method: ImageSegment>>fixCapitalizationOfSymbols (in category 'fileIn/Out') ----- fixCapitalizationOfSymbols "MultiString>>capitalized was not implemented correctly. Fix eventual accessors and mutators here." | sym ms | 1 to: outPointers size do:[:i| sym := outPointers at: i. (sym class == WideSymbol and:[sym size > 3]) ifTrue:[ ((sym beginsWith: 'get') and:[(sym at: 4) asInteger < 256 and:[(sym at: 4) isLowercase]]) ifTrue:[ ms := sym asString. ms at: 4 put: (ms at: 4) asUppercase. ms := ms asSymbol. sym becomeForward: ms. ]. ((sym beginsWith: 'set') and:[(sym at: 4) asInteger < 256 and:[(sym at: 4) isLowercase and:[sym last = $: and:[(sym occurrencesOf: $:) = 1]]]]) ifTrue:[ ms := sym asString. ms at: 4 put: (ms at: 4) asUppercase. ms := ms asSymbol. sym becomeForward: ms. ]. outPointers at: i put: sym. ]. ].!
Item was removed: - ----- Method: ImageSegment>>ifOutPointer:thenAllObjectsDo: (in category 'instance change shape') ----- - ifOutPointer: anObject thenAllObjectsDo: aBlock - | withSymbols segSize | - "If I point out to anObject, bring me in, Submit all my objects to the block. Write me out again." - - (state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self]. - withSymbols := state = #onFileWithSymbols. - (outPointers includes: anObject) ifFalse: [^ self]. - state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]]. - segSize := segment size. - self install. - self allObjectsDo: aBlock. "do the work" - self copyFromRoots: arrayOfRoots sizeHint: segSize. - self extract. - withSymbols - ifTrue: [self writeToFileWithSymbols] - ifFalse: [self writeToFile]. - - !
Item was removed: - ----- 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 = #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 removed: - ----- Method: ImageSegment>>isOnFile (in category 'testing') ----- - isOnFile - ^ state == #onFile!
Item was removed: - ----- 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." - - <primitive: 99 error: ec> "successful completion returns the array of roots" - ^nil "failure returns nil"!
Item was removed: - ----- Method: ImageSegment>>localName (in category 'read/write segment') ----- - localName - | segs ind sep | - "Return the current file name for this segment, a local name in the segments directory." - - fileName ifNil: [^ nil]. - "^ fileName" - - "The following is for backward compatibility. Remove this part after June 2000. - Check if the fileName is a full path, and make it local. Regardless of current or previous file system delimiter." - - segs := self class folder copyLast: 4. ":=segs" - ind := 1. - [ind := fileName findString: segs startingAt: ind+1 caseSensitive: false. - ind = 0 ifTrue: [^ fileName]. - sep := fileName at: ind + (segs size). - sep isAlphaNumeric ] whileTrue. "sep is letter or digit, not a separator" - - ^ fileName := fileName copyFrom: ind+(segs size)+1 "delimiter" to: fileName size!
Item was removed: - ----- Method: ImageSegment>>objectAfter: (in category 'compact classes') ----- - objectAfter: ind - "Return the object or free chunk immediately following the given object or free chunk in the segment. *** Warning: When class ObjectMemory change, be sure to change it here. ***" - - | sz word newInd hdrBits | - sz := ((word := segment at: ind "header") bitAnd: 3) = 2 "free block?" - ifTrue: [word bitAnd: 16rFFFFFFFC] - ifFalse: [(word bitAnd: 3) = 0 "HeaderTypeSizeAndClass" - ifTrue: [(segment at: ind-2) bitAnd: 16rFFFFFFFC] - ifFalse: [word bitAnd: "SizeMask" 252]]. - - newInd := ind + (sz>>2). - "adjust past extra header words" - (hdrBits := (segment atPin: newInd) bitAnd: 3) = 3 ifTrue: [^ newInd]. - "If at end, header word will be garbage. This is OK" - hdrBits = 1 ifTrue: [^ newInd+1]. - hdrBits = 0 ifTrue: [^ newInd+2]. - ^ newInd "free"!
Item was removed: - ----- Method: ImageSegment>>originalRoots (in category 'access') ----- - originalRoots - "Return only the roots that the user submitted, not the ones we had to add." - - userRootCnt ifNil: [^ arrayOfRoots]. - ^ arrayOfRoots copyFrom: 1 to: userRootCnt!
Item was removed: - ----- Method: ImageSegment>>outPointers (in category 'access') ----- - outPointers - ^ outPointers!
Item was removed: - ----- Method: ImageSegment>>prepareToBeSaved (in category 'fileIn/Out') ----- - prepareToBeSaved - "Prepare objects in outPointers to be written on the disk. They must be able to match up with existing objects in their new system. outPointers is already a copy. - Classes are already converted to a DiskProxy. - Associations in outPointers: - 1) in Smalltalk. - 2) in a classPool. - 3) in a shared pool. - 4) A pool dict pointed at directly" - - | left myClasses outIndexes | - self flag: #environments. - myClasses := Set new. - arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [myClasses add: aRoot]]. - outIndexes := IdentityDictionary new. - outPointers withIndexDo: [:anOut :ind | | key | - anOut isVariableBinding ifTrue: [ - (myClasses includes: anOut value) - ifFalse: [outIndexes at: anOut put: ind] - ifTrue: [(Smalltalk globals associationAt: anOut key ifAbsent: [3]) == anOut - ifTrue: [outPointers at: ind put: - (DiskProxy global: #Smalltalk selector: #associationDeclareAt: - args: (Array with: anOut key))] - ifFalse: [outIndexes at: anOut put: ind] - ]]. - (anOut isKindOf: Dictionary) ifTrue: ["Pools pointed at directly" - (key := Smalltalk globals keyAtIdentityValue: anOut ifAbsent: [nil]) ifNotNil: [ - outPointers at: ind put: - (DiskProxy global: key selector: #yourself args: #())]]. - anOut isMorph ifTrue: [outPointers at: ind put: - (StringMorph contents: anOut printString, ' that was not counted')] - ]. - left := outIndexes keys asSet. - left size > 0 ifTrue: ["Globals" - (left copy) do: [:assoc | "stay stable while delete items" - (Smalltalk globals associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ - outPointers at: (outIndexes at: assoc) put: - (DiskProxy global: #Smalltalk selector: #associationAt: - args: (Array with: assoc key)). - left remove: assoc]]]. - left size > 0 ifTrue: ["Class variables" - Smalltalk allClassesDo: [:cls | cls classPool size > 0 ifTrue: [ - (left copy) do: [:assoc | "stay stable while delete items" - (cls classPool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ - outPointers at: (outIndexes at: assoc) put: - (DiskProxy new global: cls name - preSelector: #classPool - selector: #associationAt: - args: (Array with: assoc key)). - left remove: assoc]]]]]. - left size > 0 ifTrue: ["Pool variables" - Smalltalk globals associationsDo: [:poolAssoc | | pool | - poolAssoc value class == Dictionary ifTrue: ["a pool" - pool := poolAssoc value. - (left copy) do: [:assoc | "stay stable while delete items" - (pool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ - outPointers at: (outIndexes at: assoc) put: - (DiskProxy global: poolAssoc key selector: #associationAt: - args: (Array with: assoc key)). - left remove: assoc]]]]]. - left size > 0 ifTrue: [ - "If points to class in arrayOfRoots, must deal with it separately" - "OK to have obsolete associations that just get moved to the new system" - self inform: 'extra associations'. - left inspect]. - !
Item was removed: - ----- Method: ImageSegment>>printSpaceAnalysisOn: (in category 'statistics') ----- - printSpaceAnalysisOn: aStream - "Capture statistics about the IS and print the number of instances per class and space usage" - | instCount instSpace sorted sum1 sum2 | - instCount := self doSpaceAnalysis. - instSpace := instCount last. - instCount := instCount first. - sorted := SortedCollection sortBlock:[:a1 :a2| a1 value >= a2 value]. - instSpace associationsDo:[:a| sorted add: a]. - sorted do:[:assoc| - aStream cr; nextPutAll: assoc key; tab. - aStream print: (instCount at: assoc key); nextPutAll:' instances '. - aStream print: assoc value; nextPutAll: ' bytes '. - ]. - sum1 := instCount inject: 0 into:[:sum :n| sum + n]. - sum2 := instSpace inject: 0 into:[:sum :n| sum + n]. - aStream cr; cr. - aStream print: sum1; nextPutAll:' instances '. - aStream print: sum2; nextPutAll: ' bytes '. - !
Item was removed: - ----- 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). - ff close. - state := #active!
Item was added: + ----- Method: ImageSegment>>rehashDictionaries: (in category 'fileIn') ----- + rehashDictionaries: aCollection + ProgressInitiationException + display: 'Rehash objects...' + during: [:bar | 1 + to: aCollection size + do: [:i | + (aCollection at: i) rehash. + i \ 10 = 0 + ifTrue: [bar value: i / aCollection size]]]!
Item was removed: - ----- 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 | - 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]]]. - hashedCollections do: [ :each | each compact ]. "our purpose" - ^receiverClasses "our secondary job"!
Item was changed: + ----- Method: ImageSegment>>reshapeClasses:refStream: (in category 'fileIn') ----- - ----- Method: ImageSegment>>reshapeClasses:refStream: (in category 'fileIn/Out') ----- 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 | perfect := smartRefStream convert1: misShapen to: theRealClass allVarMaps: allVarMaps. 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 detect: [ :x | x == each] ifNone: [ in add: each. out add: perfect ] ]. in isEmpty ifFalse: [ in asArray elementsForwardIdentityTo: out asArray ]. !
Item was removed: - ----- Method: ImageSegment>>restoreEndianness (in category 'fileIn/Out') ----- - restoreEndianness - ^self restoreEndianness: self endianness ~~ Smalltalk endianness!
Item was changed: + ----- Method: ImageSegment>>restoreEndianness: (in category 'fileIn') ----- - ----- Method: ImageSegment>>restoreEndianness: (in category 'fileIn/Out') ----- restoreEndianness: endiannessHasToBeFixed + "If endiannessHasToBeFixed, then 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. - "If endiannessHasToBeFixed, then 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."
+ | sets receiverClasses noStartUpNeeded startUps cls msg | + sets := 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." - | hashedCollections receiverClasses noStartUpNeeded startUps | - - hashedCollections := OrderedCollection new. 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 | + object isInMemory ifTrue: [ + (object isKindOf: HashedCollection) ifTrue: [sets add: object]. + ((object isKindOf: ContextPart) 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: endiannessHasToBeFixed. "a Message, if we need to swap bytes this time" + msg ifNil: [noStartUpNeeded add: cls] - 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: endiannessHasToBeFixed. "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]]]]. + self rehashDictionaries: sets. "our purpose" + ^ receiverClasses "our secondary job" + ! - msg ifNotNil: [msg sentTo: object]]]. - hashedCollections do: [ :each | each compact ]. "our purpose" - ^ receiverClasses "our secondary job"!
Item was removed: - ----- 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] - - "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."!
Item was removed: - ----- Method: ImageSegment>>rootsIncludingBlockMethods (in category 'read/write segment') ----- - rootsIncludingBlockMethods - "Return a new roots array with more objects. (Caller should store into rootArray.) Any CompiledMethods that create blocks will be in outPointers if the block is held outside of this segment. Put such methods into the roots list. Then ask for the segment again." - - | myClasses extras | - userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. - extras := OrderedCollection new. - myClasses := OrderedCollection new. - arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [ - myClasses add: aRoot]]. - myClasses isEmpty ifTrue: [^ nil]. "no change" - outPointers do: [:anOut | | gotIt | - anOut class == CompiledMethod ifTrue: [ - "specialized version of who" - gotIt := false. - myClasses detect: [:class | - class methodsDo: [:m | - m == anOut - ifTrue: [extras add: anOut. gotIt := true]]. - gotIt] - ifNone: [] - ]. - ]. - extras := extras select: [:ea | (arrayOfRoots includes: ea) not]. - extras isEmpty ifTrue: [^ nil]. "no change" - ^ arrayOfRoots, extras!
Item was removed: - ----- Method: ImageSegment>>rootsIncludingBlocks (in category 'read/write segment') ----- - rootsIncludingBlocks - "For export segments only. Return a new roots array with more objects. (Caller should store into rootArray.) Collect Blocks and external methods pointed to by them. Put them into the roots list. Then ask for the segment again." - - | extras have | - userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. - extras := OrderedCollection new. - outPointers do: [:anOut | - anOut class == CompiledMethod ifTrue: [extras add: anOut]. - (anOut isBlock) ifTrue: [extras add: anOut]. - (anOut class == MethodContext) ifTrue: [extras add: anOut]]. - - [have := extras size. - extras copy do: [:anOut | - anOut isBlock ifTrue: [ - anOut home ifNotNil: [ - (extras includes: anOut home) ifFalse: [extras add: anOut home]]]. - (anOut class == MethodContext) ifTrue: [ - anOut method ifNotNil: [ - (extras includes: anOut method) ifFalse: [extras add: anOut method]]]]. - have = extras size] whileFalse. - extras := extras select: [:ea | (arrayOfRoots includes: ea) not]. - extras isEmpty ifTrue: [^ nil]. "no change" - - ^ arrayOfRoots, extras!
Item was removed: - ----- Method: ImageSegment>>rootsIncludingPlayers (in category 'read/write segment') ----- - rootsIncludingPlayers - "Return a new roots array with more objects. (Caller should store into rootArray.) Player (non-systemDefined) gets its class and metaclass put into the Roots array. Then ask for the segment again." - - | extras havePresenter players morphs existing | - userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. - extras := OrderedCollection new. - arrayOfRoots do: [:root | - (root isKindOf: Presenter) ifTrue: [havePresenter := root]. - (root isKindOf: PasteUpMorph) ifTrue: [ - root isWorldMorph ifTrue: [havePresenter := root presenter]]. - (root isKindOf: Project) ifTrue: [havePresenter := root world presenter]]. - havePresenter ifNotNil: [ - havePresenter flushPlayerListCache. "old and outside guys" - morphs := IdentitySet new: 400. - havePresenter associatedMorph allMorphsAndBookPagesInto: morphs. - players := (morphs select: [:m | m player ~~ nil] - thenCollect: [:m | m player]) asArray. - players := players select: [:ap | (arrayOfRoots includes: ap class) not - & (ap class isSystemDefined not)]. - extras addAll: (players collect: [:each | each class]). - extras addAll: (players collect: [:each | each class class]). - extras addAll: morphs. "Make then ALL roots!!" - ]. - existing := arrayOfRoots asIdentitySet. - extras := extras reject: [ :each | existing includes: each]. - extras isEmpty ifTrue: [^ nil]. "no change" - - havePresenter := players := morphs := nil. - ^ arrayOfRoots, extras "will contain multiples of some, but reduced later" - !
Item was removed: - ----- Method: ImageSegment>>savePlayerReferences: (in category 'read/write segment') ----- - savePlayerReferences: dictOfAllObjects - | save world | - "Save our associations we own in the shared References table. They will be installed when the segment is imported." - - save := OrderedCollection new. - References associationsDo: [:assoc | - (dictOfAllObjects includesKey: assoc) ifTrue: [save add: assoc]]. - 1 to: 5 do: [:ii | ((arrayOfRoots at: ii) respondsTo: #isCurrentProject) ifTrue: [ - world := (arrayOfRoots at: ii) world]]. - world setProperty: #References toValue: save. - "assume it is not refed from outside and will be traced"!
Item was removed: - ----- 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 removed: - ----- Method: ImageSegment>>scanFrom:environment: (in category 'fileIn/Out') ----- - scanFrom: aStream environment: anEnvironment - ^ self scanFrom: aStream!
Item was removed: - ----- Method: ImageSegment>>segUpdateInstancesOf:toBe:isMeta: (in category 'instance change shape') ----- - segUpdateInstancesOf: oldClass toBe: newClass isMeta: isMeta - | withSymbols oldInstances segSize | - "Bring me in, locate instances of oldClass and get them converted. Write me out again." - - (state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self]. - withSymbols := state = #onFileWithSymbols. - "If has instances, they point out at the class" - (outPointers includes: oldClass) ifFalse: [ - oldClass == SmallInteger ifTrue: [^ self]. "instance not changable" - oldClass == Symbol ifTrue: [^ self]. "instance is never in a segment" - oldClass == ByteSymbol ifTrue: [^ self]. "instance is never in a segment" - (Smalltalk compactClassesArray includes: oldClass) ifFalse: [^ self]]. - "For a compact class, must search the segment. Instance does not - point outward to class" - state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]]. - segSize := segment size. - self install. - oldInstances := OrderedCollection new. - self allObjectsDo: [:obj | obj class == oldClass ifTrue: [ - oldInstances add: obj]]. - newClass updateInstances: oldInstances asArray from: oldClass isMeta: isMeta. - self copyFromRoots: arrayOfRoots sizeHint: segSize. - self extract. - withSymbols - ifTrue: [self writeToFileWithSymbols] - ifFalse: [self writeToFile]. - !
Item was removed: - ----- Method: ImageSegment>>segment (in category 'access') ----- - segment - ^ segment!
Item was removed: - ----- Method: ImageSegment>>segmentCopy (in category 'read/write segment') ----- - segmentCopy - "This operation will install a copy of the segment in memory, and return a copy of the array of roots. The effect is to perform a deep copy of the original structure. Note that installation destroys the segment, so it must be copied before doing the operation." - - state = #activeCopy ifFalse: [self errorWrongState]. - ^ self loadSegmentFrom: segment copy outPointers: outPointers!
Item was removed: - ----- Method: ImageSegment>>segmentName (in category 'read/write segment') ----- - segmentName - "Return the local file name for this segment." - - ^ segmentName!
Item was removed: - ----- Method: ImageSegment>>segmentName: (in category 'read/write segment') ----- - segmentName: aString - "Local file name for this segment." - - segmentName := aString!
Item was removed: - ----- Method: ImageSegment>>smartFillRoots: (in category 'read/write segment') ----- - smartFillRoots: dummy - | refs known ours ww blockers | - "Put all traced objects into my arrayOfRoots. Remove some - that want to be in outPointers. Return blockers, an - IdentityDictionary of objects to replace in outPointers." - - blockers := dummy blockers. - known := (refs := dummy references) size. - refs keys do: [:obj | "copy keys to be OK with removing items" - (obj isSymbol) ifTrue: [refs removeKey: obj. known := known-1]. - (obj class == PasteUpMorph) ifTrue: [ - obj isWorldMorph & (obj owner == nil) ifTrue: [ - (dummy project ~~ nil and: [obj == dummy project world]) ifFalse: [ - refs removeKey: obj. known := known-1. - blockers at: obj put: - (StringMorph contents: 'The worldMorph of a different world')]]]. - "Make a ProjectViewMorph here" - "obj class == Project ifTrue: [Transcript show: obj; cr]." - (blockers includesKey: obj) ifTrue: [ - refs removeKey: obj ifAbsent: [known := known+1]. known := known-1]. - ]. - ours := dummy project ifNotNil: [dummy project world] ifNil: [ActiveWorld]. - refs keysDo: [:obj | - obj isMorph ifTrue: [ - ww := obj world. - (ww == ours) | (ww == nil) ifFalse: [ - refs removeKey: obj. known := known-1. - blockers at: obj put: (StringMorph contents: - obj printString, ' from another world')]]]. - "keep original roots on the front of the list" - (dummy rootObject) do: [:rr | refs removeKey: rr ifAbsent: []]. - self classOrganizersBeRoots: dummy. - ^ dummy rootObject, refs fasterKeys asArray.!
Item was removed: - ----- Method: ImageSegment>>state (in category 'access') ----- - state - ^ state!
Item was removed: - ----- Method: ImageSegment>>storeDataOn: (in category 'fileIn/Out') ----- - storeDataOn: aDataStream - "Don't wrote the array of Roots. Also remember the structures of the classes of objects inside the segment." - - | tempRoots tempOutP list | - state = #activeCopy ifFalse: [self error: 'wrong state']. - "real state is activeCopy, but we changed it will be right when coming in" - tempRoots := arrayOfRoots. - tempOutP := outPointers. - outPointers := outPointers clone. - self prepareToBeSaved. - arrayOfRoots := nil. - state := #imported. - super storeDataOn: aDataStream. "record my inst vars" - arrayOfRoots := tempRoots. - outPointers := tempOutP. - state := #activeCopy. - aDataStream references at: #AnImageSegment put: false. "the false is meaningless" - "This key in refs is the flag that there is an ImageSegment in this file." - - "Find the receivers of blocks in the segment. Need to get the structure of their classes into structures. Put the receivers into references." - (aDataStream byteStream isKindOf: DummyStream) ifTrue: [ - list := Set new. - arrayOfRoots do: [:ea | - ea isBlock | (ea class == MethodContext) ifTrue: [ - list add: ea receiver class ]]. - aDataStream references at: #BlockReceiverClasses put: list]. - !
Item was removed: - ----- Method: ImageSegment>>storeSegmentFor:into:outPointers: (in category 'primitives') ----- - storeSegmentFor: rootsArray into: segmentWordArray outPointers: outPointerArray - "This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree). Note: all elements of the reciever are treated as roots indetermining the extent of the tree. All pointers from within the tree to objects outside the tree 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 4). but with the high bit set." - - "The primitive expects the array and wordArray to be more than adequately long. In this case it returns normally, and truncates the two arrays to exactly the right size. If either array is too small, the primitive will fail, but in no other case." - - <primitive: 98> "successful completion returns self" - ^ nil "failure returns nil"!
Item was removed: - ----- 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]. - (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]. - 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 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 removed: - ----- Method: ImageSegment>>verifyCopy (in category 'testing') ----- - verifyCopy - - | copyOfRoots matchDict | - copyOfRoots := self segmentCopy. - matchDict := IdentityDictionary new. - arrayOfRoots with: copyOfRoots do: - [:r :c | self verify: r matches: c knowing: matchDict]!
Item was removed: - ----- 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 | - state = #activeCopy ifFalse: [self error: 'wrong state']. - fileStream := FileStream newFileNamed: (FileDirectory fileName: shortName extension: self class fileExtension). - fileStream fileOutClass: nil andObject: self. - "remember extra structures. Note class names."!
Item was removed: - ----- 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 | - state = #activeCopy ifFalse: [self error: 'wrong state']. - (fName includes: $.) ifFalse: [ - ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. - 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." - - "append sources" - allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior]. - 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!
Item was removed: - ----- 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 | - state = #activeCopy ifFalse: [self error: 'wrong state']. - (fName includes: $.) ifFalse: [ - ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at - the end of the file name']. - 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." - - "append sources" - allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior]. - 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 - !
Item was removed: - ----- 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 | - state = #activeCopy ifFalse: [self error: 'wrong state']. - (fName includes: $.) ifFalse: [ - ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. - fileStream := GZipSurrogateStream newFileNamed: fName inDirectory: aDirectory. - fileStream fileOutClass: nil andObject: self. - "remember extra structures. Note class names." - - "append sources" - allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior]. - 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" - !
Item was removed: - ----- 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. - state := #onFile].!
Item was removed: - ----- Method: ImageSegment>>writeToFile: (in category 'read/write segment') ----- - writeToFile: shortName - "The short name can't have any fileDelimiter characters in it. It is remembered in case the segment must be brought in and then sent out again (see ClassDescription updateInstancesFrom:)." - - segmentName := (shortName endsWith: '.seg') - ifTrue: [shortName copyFrom: 1 to: shortName size - 4] - ifFalse: [shortName]. - segmentName last isDigit ifTrue: [segmentName := segmentName, '-']. - self writeToFile.!
Item was removed: - ----- Method: ImageSegment>>writeToFileWithSymbols (in category 'read/write segment') ----- - writeToFileWithSymbols - | symbols nonSymbols pound | - - state = #extracted ifFalse: [self error: 'wrong state']. - segmentName ifNil: [ - segmentName := (FileDirectory localNameFor: fileName) sansPeriodSuffix]. - "OK that still has number on end. This is an unusual case" - fileName := self class uniqueFileNameFor: segmentName. - symbols := OrderedCollection new. - nonSymbols := OrderedCollection new. - pound := '#' asSymbol. - outPointers do: - [:s | - ((s isSymbol) and: [s isLiteral and: [s ~~ pound]]) - ifTrue: [symbols addLast: s] - ifFalse: [symbols addLast: pound. nonSymbols addLast: s]]. - (self class segmentDirectory newFileNamed: fileName) - store: symbols asArray; cr; - nextPutAll: segment; close. - outPointers := nonSymbols asArray. - state := #onFileWithSymbols!
Item was removed: - ----- Method: ImageSegment>>writeToFileWithSymbols: (in category 'read/write segment') ----- - writeToFileWithSymbols: shortName - - segmentName := (shortName endsWith: '.seg') - ifTrue: [shortName copyFrom: 1 to: shortName size - 4] - ifFalse: [shortName]. - segmentName last isDigit ifTrue: [segmentName := segmentName, '-']. - self writeToFileWithSymbols.!
Item was added: + Object subclass: #ImageSegmentLoader + instanceVariableNames: 'segment outPointers oopMap position' + classVariableNames: 'BytesInHeader CompactClasses HeaderTypeClass HeaderTypeFree HeaderTypeMask HeaderTypeShort HeaderTypeSizeAndClass' + poolDictionaries: '' + category: 'System-Object Storage'! + + !ImageSegmentLoader commentStamp: 'bf 8/16/2016 18:16' prior: 0! + This class is used to load objects from an ImageSegment that is incompatible with the current VM (see ImageSegment>>loadSegmentFrom:outPointers:).!
Item was added: + ----- Method: ImageSegmentLoader class>>initialize (in category 'class initialization') ----- + initialize + HeaderTypeMask := 3. + HeaderTypeSizeAndClass := 0. "3-word header" + HeaderTypeClass := 1. "2-word header" + HeaderTypeFree := 2. "free block" + HeaderTypeShort := 3. "1-word header" + BytesInHeader := { + HeaderTypeSizeAndClass -> 12. + HeaderTypeClass -> 8. + HeaderTypeShort -> 4. + } as: Dictionary. + "explicit list in case image has no/different compact classes" + CompactClasses := {CompiledMethod. nil. Array. nil. + LargePositiveInteger. Float. MethodDictionary. Association. + Point. Rectangle. ByteString. nil. + BlockContext. MethodContext. nil. Bitmap. + nil. nil. nil. nil. nil. nil. nil. nil. nil. nil. nil. nil. nil. nil. nil}. + !
Item was added: + ----- Method: ImageSegmentLoader>>allocateBlockContext: (in category 'allocating') ----- + allocateBlockContext: nWords + | homeOop methodOop method | + homeOop := self uint32At: position + 24. + methodOop := self uint32At: homeOop + 16. + method := self readObjectAt: methodOop. + ^BlockContext newForMethod: method.!
Item was added: + ----- Method: ImageSegmentLoader>>allocateBytesObject:size: (in category 'allocating') ----- + allocateBytesObject: classOop size: nBytes + | class | + class := self fetchClass: classOop. + class isBytes ifFalse: + [self error: 'bytes class expected']. + ^class basicNew: nBytes!
Item was added: + ----- Method: ImageSegmentLoader>>allocateCompiledMethod: (in category 'allocating') ----- + allocateCompiledMethod: nBytes + "CompiledMethods need special handling: + - the method header bits changed + - the primitive is now the first 3 bytecodes + - the trailer encoding changed, too + Here we calculate the new size needed after adding + the primitive byte codes, stripping the old trailer and + adding one byte for the NoTrailer code." + | header numLits bytecodes lastByte trailerBytes | + header := self mapOop: (self uint32At: position + 4). + header := self mapToSpurHeader: header. + numLits := header bitAnd: 16rFF. + bytecodes := nBytes - (1 + numLits * 4). "subtract header and literals" + lastByte := self uint8At: position + nBytes. + trailerBytes := lastByte = 0 ifTrue: "up to four 0 bytes" + [(self uint8At: position + nBytes - 1) = 0 ifFalse: [1] ifTrue: + [(self uint8At: position + nBytes - 2) = 0 ifFalse: [2] ifTrue: + [(self uint8At: position + nBytes - 3) = 0 ifFalse: [3] ifTrue: [4]]]] ifFalse: + [lastByte < 252 ifTrue: + [lastByte + 1 "Magic sources (tempnames encoded in last bytes)"] ifFalse: + [4 "Normal 4-byte source pointer"]]. + "subtract old trailer, add 1 byte for new trailer" + bytecodes := (bytecodes - trailerBytes max: 0) + 1. + "add 3 bytes for prim call" + (header bitAnd: 16r10000) > 0 ifTrue: [bytecodes := bytecodes + 3]. + ^CompiledMethod newMethod: bytecodes header: header!
Item was added: + ----- Method: ImageSegmentLoader>>allocateFixedAndVariableObject:size: (in category 'allocating') ----- + allocateFixedAndVariableObject: classOop size: nWords + | class | + classOop = 13 ifTrue: + [^self allocateBlockContext: nWords]. + classOop = 14 ifTrue: + [^self allocateMethodContext: nWords]. + class := self fetchClass: classOop. + (class isPointers and: [class isVariable]) ifFalse: + [self error: 'variable pointers class expected']. + ^class basicNew: nWords - class instSize!
Item was added: + ----- Method: ImageSegmentLoader>>allocateFixedSizeObject:size: (in category 'allocating') ----- + allocateFixedSizeObject: classOop size: nWords + | class | + class := self fetchClass: classOop. + (class isPointers and: [class isFixed]) ifFalse: + [self error: 'fixed pointers class expected']. + class instSize = nWords ifFalse: [self halt]. + ^class basicNew!
Item was added: + ----- Method: ImageSegmentLoader>>allocateMethodContext: (in category 'allocating') ----- + allocateMethodContext: nWords + | methodOop method | + methodOop := self uint32At: position + 16. + method := self readObjectAt: methodOop. + ^MethodContext newForMethod: method.!
Item was added: + ----- Method: ImageSegmentLoader>>allocateObject:class:size: (in category 'allocating') ----- + allocateObject: format class: class size: nWords + | nBytes | + format <= 1 ifTrue: + [^self allocateFixedSizeObject: class size: nWords]. + format = 2 ifTrue: + [^self allocateVariableSizeObject: class size: nWords]. + (format between: 3 and: 4) ifTrue: + [^self allocateFixedAndVariableObject: class size: nWords]. + format = 6 ifTrue: + [^self allocateWordsObject: class size: nWords]. + nBytes := (nWords * 4) - (format bitAnd: 3). + format >= 12 ifTrue: + [^self allocateCompiledMethod: nBytes]. + format >= 8 ifTrue: + [^self allocateBytesObject: class size: nBytes]. + self error: 'Unknown object format'. + !
Item was added: + ----- Method: ImageSegmentLoader>>allocateVariableSizeObject:size: (in category 'allocating') ----- + allocateVariableSizeObject: classOop size: nWords + | class | + class := self fetchClass: classOop. + (class isPointers and: [class isVariable]) ifFalse: + [self error: 'variable pointers class expected']. + ^class basicNew: nWords!
Item was added: + ----- Method: ImageSegmentLoader>>allocateWordsObject:size: (in category 'allocating') ----- + allocateWordsObject: classOop size: nWords + | class | + class := self fetchClass: classOop. + class == Float ifTrue: [class := BoxedFloat64]. + (class isBits and: [class isWords]) ifFalse: + [self error: 'words class expected']. + ^class basicNew: nWords!
Item was added: + ----- Method: ImageSegmentLoader>>fetchClass: (in category 'reading') ----- + fetchClass: classOop + | index class superclass format | + classOop < 32 ifTrue: + [^CompactClasses at: classOop]. + (index := classOop >> 2) >= 16r20000000 ifTrue: + [^outPointers at: index - 16r20000000]. + "class is in segment ... load it out-of-order" + superclass := self fetchClass: (self uint32At: classOop + 4). + format := self mapOop: (self uint32At: classOop + 12). + format := self mapToSpurFormat: format. + class := self readObjectAt: classOop. + class superclass: superclass + methodDictionary: MethodDictionary new + format: format. + class flushCache. + ^class!
Item was added: + ----- Method: ImageSegmentLoader>>fillBehavior:oop: (in category 'filling') ----- + fillBehavior: class oop: oop + position := oop. + class superclass: (self mapOop: self readUint32). + class methodDict: (self mapOop: self readUint32). + class setFormat: (self mapToSpurFormat: (self mapOop: self readUint32)). + 4 to: class class instSize do: + [:i | class instVarAt: i put: (self mapOop: self readUint32)]. + class flushCache. + ^class!
Item was added: + ----- Method: ImageSegmentLoader>>fillBytes:oop: (in category 'filling') ----- + fillBytes: object oop: oop + | word | + position := oop. + word := self readUint32. + 1 to: object basicSize do: + [:i | object basicAt: i put: (word bitAnd: 16rFF). + word := (i bitAnd: 3) = 0 + ifTrue: [self readUint32] + ifFalse: [word >> 8]]. + !
Item was added: + ----- Method: ImageSegmentLoader>>fillCompiledMethod:oop: (in category 'filling') ----- + fillCompiledMethod: method oop: oop + "The method header was already mapped to Spur format. + Here we just insert the bytecode for calling a primitive. + The last byte is left at 0 to indicate no trailer." + | header start size prim word | + position := oop. + header := self mapOop: self readUint32. + 1 to: method numLiterals do: + [:i | method literalAt: i put: (self mapOop: self readUint32)]. + start := method initialPC - 1. + size := method basicSize - start - 1. "subtract 1 byte for empty trailer" + (method header anyMask: 65536) ifTrue: "add primitive call" + [prim := self mapToSpurPrim: header. + method basicAt: start + 1 put: 16r8B. + method basicAt: start + 2 put: prim \ 256. + method basicAt: start + 3 put: prim // 256. + start := start + 3. + size := size - 3]. + word := self readUint32. + 1 to: size do: + [:i | method basicAt: start + i put: (word bitAnd: 16rFF). + word := (i bitAnd: 3) = 0 + ifTrue: [self readUint32] + ifFalse: [word >> 8]]. + !
Item was added: + ----- Method: ImageSegmentLoader>>fillContext:oop: (in category 'filling') ----- + fillContext: ctx oop: oop + position := oop. + 1 to: ctx class instSize do: + [:i | ctx instVarAt: i put: (self mapOop: self readUint32)]. + 1 to: ctx stackPtr do: + [:i | ctx basicAt: i put: (self mapOop: self readUint32)]. + ^ctx!
Item was added: + ----- Method: ImageSegmentLoader>>fillObject:oop: (in category 'filling') ----- + fillObject: object oop: oop + object isBehavior ifTrue: + [^self fillBehavior: object oop: oop]. + object isContext ifTrue: + [^self fillContext: object oop: oop]. + object class isPointers ifTrue: + [^self fillPointers: object oop: oop]. + object isCompiledMethod ifTrue: + [^self fillCompiledMethod: object oop: oop]. + object class isBytes ifTrue: + [^self fillBytes: object oop: oop]. + ^self fillWords: object oop: oop + + !
Item was added: + ----- Method: ImageSegmentLoader>>fillPointers:oop: (in category 'filling') ----- + fillPointers: object oop: oop + position := oop. + 1 to: object class instSize do: + [:i | object instVarAt: i put: (self mapOop: self readUint32)]. + 1 to: object basicSize do: + [:i | object basicAt: i put: (self mapOop: self readUint32)]. + ^object!
Item was added: + ----- Method: ImageSegmentLoader>>fillWords:oop: (in category 'filling') ----- + fillWords: object oop: oop + position := oop. + 1 to: object basicSize do: + [:i | object basicAt: i put: self readUint32]. + !
Item was added: + ----- Method: ImageSegmentLoader>>loadSegmentFrom:outPointers: (in category 'loading') ----- + loadSegmentFrom: segmentWordArray outPointers: outPointerArray + | version end memory | + segment := segmentWordArray. + outPointers := outPointerArray. + position := 0. + version := self readUint32. + (version bitAnd: 16rFFFF) = 6502 ifFalse: + [^self error: 'Cannot read this segment (endianness?)']. + "First allocate all objects, then fill in their fields via oopMap" + memory := OrderedCollection new: 1000. + oopMap := Dictionary new. + end := segment size * 4. + [position < end] whileTrue: + [memory add: self readObject]. + oopMap keysAndValuesDo: + [:oop :obj | self fillObject: obj oop: oop]. + "Return list of all objects (unlike primitive, which returned the first object and relied on other objects being consecutive in memory)" + ^memory!
Item was added: + ----- Method: ImageSegmentLoader>>mapOop: (in category 'reading') ----- + mapOop: oop + | i | + (oop bitAnd: 1) = 0 ifTrue: "pointer" + [(i := oop >> 2) >= 16r20000000 ifTrue: + [^outPointers at: i - 16r20000000]. + ^oopMap at: oop]. + i := oop >> 1. "signed small int" + i <= 16r3FFFFFFF ifTrue: [^i]. + ^i - 16r80000000!
Item was added: + ----- Method: ImageSegmentLoader>>mapToSpurFormat: (in category 'reading') ----- + mapToSpurFormat: format + | instSpec instSize | + instSpec := format >> 7 bitAnd: 16r0F. + instSize := (format >> 10 bitAnd: 16rC0) + (format >> 1 bitAnd: 16r3F) - 1. + instSpec := instSpec <= 4 + ifTrue: [instSpec] "no change" + ifFalse: [instSpec = 6 + ifTrue: [10] "WordArray was 6 now 10-11" + ifFalse: [instSpec >= 12 + ifTrue: [instSpec + 12] "CompiledMethods 12-15 now 24-31" + ifFalse: [instSpec >= 8 + ifTrue: [instSpec + 8] "CompiledMethods 8-11 now 16-23" + ifFalse: [self error: 'unexpected format']]]]. + ^instSpec << 16 + instSize!
Item was added: + ----- Method: ImageSegmentLoader>>mapToSpurHeader: (in category 'reading') ----- + mapToSpurHeader: header + "Keep numLits, numArgs, and largeFrame bits, move numLits, set primitive flag" + | primFlag numLits | + primFlag := (header bitAnd: 16r100001FF) > 0 ifTrue: [16r10000] ifFalse: [0]. + numLits := header >> 9 bitAnd: 16rFF. + ^(header bitAnd: 16r0FFE0000) + primFlag + numLits + !
Item was added: + ----- Method: ImageSegmentLoader>>mapToSpurPrim: (in category 'reading') ----- + mapToSpurPrim: header + | primBits | + primBits := header bitAnd: 16r100001FF. + ^(primBits bitAnd: 16r1FF) + (primBits bitShift: -19)!
Item was added: + ----- Method: ImageSegmentLoader>>readObject (in category 'reading') ----- + readObject + | header oop nWords class format | + header := self readUint32. + (header bitAnd: HeaderTypeMask) caseOf: { + [HeaderTypeSizeAndClass] -> + [nWords := header >> 2. class := self readUint32. header := self readUint32]. + [HeaderTypeClass] -> + [class := header - 1. header := self readUint32. nWords := header >> 2 bitAnd: 63]. + [HeaderTypeShort] -> + [nWords := header >> 2 bitAnd: 63. class := header >> 12 bitAnd: 31]. + } otherwise: [self error: 'unexpected free chunk']. + nWords := nWords - 1. "nWords includes 1 header word" + oop := position. + ^[oopMap at: oop ifAbsentPut: + [format := header >> 8 bitAnd: 15. + "hash := header >> 17 bitAnd: 4095." + self allocateObject: format class: class size: nWords]] + ensure: [position := oop + (nWords * 4)] + + + !
Item was added: + ----- Method: ImageSegmentLoader>>readObjectAt: (in category 'reading') ----- + readObjectAt: oop + | headerType oldPos | + oopMap at: oop ifPresent: [:obj | ^obj]. + headerType := (self uint32At: oop) bitAnd: HeaderTypeMask. + oldPos := position. + position := oop - (BytesInHeader at: headerType). + ^[self readObject] ensure: [position := oldPos]!
Item was added: + ----- Method: ImageSegmentLoader>>readUint32 (in category 'reading') ----- + readUint32 + ^self uint32At: (position := position + 4)!
Item was added: + ----- Method: ImageSegmentLoader>>uint32At: (in category 'reading') ----- + uint32At: addr + "TODO: do endian conversion here" + ^segment at: addr // 4!
Item was added: + ----- Method: ImageSegmentLoader>>uint8At: (in category 'reading') ----- + uint8At: addr + "TODO: do endian conversion here" + | word | + word := segment at: addr + 3 // 4. + ^word >> (8 * (addr + 3 \ 4)) bitAnd: 16rFF.!
Item was changed: ----- Method: Project>>setParent: (in category 'sub-projects & hierarchy') ----- setParent: newParent
"Notify the current parent to discard views and other references. Avoids deleting that project later if the former parent is deleted. You can only have one parent anyway.." + (self parent isKindOf: Project) ifTrue: [ + self parent ~= newParent ifTrue: [self parent deletingProject: self]. + ]. - self parent ~= newParent ifTrue: [self parent deletingProject: self].
parentProject := newParent. nextProject := previousProject := nil.!
Item was changed: ----- Method: SmalltalkImage>>snapshot:andQuit:withExitCode:embedded: (in category 'snapshot and quit') ----- snapshot: save andQuit: quit withExitCode: exitCode embedded: embeddedFlag "Mark the changes file and close all files as part of #processShutdownList. If save is true, save the current state of this Smalltalk in the image file. If quit is true, then exit to the outer OS shell. If exitCode is not nil, then use it as exit code. The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up."
| resuming msg | Object flushDependents. Object flushEvents.
(SourceFiles at: 2) ifNotNil:[ msg := String streamContents: [ :s | s nextPutAll: '----'; nextPutAll: (save ifTrue: [ quit ifTrue: [ 'QUIT' ] ifFalse: [ 'SNAPSHOT' ] ] ifFalse: [quit ifTrue: [ 'QUIT/NOSAVE' ] ifFalse: [ 'NOP' ]]); nextPutAll: '----'; print: Date dateAndTimeNow; space; nextPutAll: (FileDirectory default localNameFor: self imageName); nextPutAll: ' priorSource: '; print: LastQuitLogPosition ]. self assureStartupStampLogged. save ifTrue: [ LastQuitLogPosition := (SourceFiles at: 2) setToEnd; position ]. self logChange: msg. Transcript cr; show: msg ].
Smalltalk processShutDownList: quit. Cursor write show. save ifTrue: [resuming := embeddedFlag ifTrue: [self snapshotEmbeddedPrimitive] + ifFalse: [self snapshotPrimitive]] "<-- PC frozen here on image file" - ifFalse: [self snapshotPrimitive]. "<-- PC frozen here on image file" - resuming == false "guard against failure" ifTrue: - ["Time to reclaim segment files is immediately after a save" - Smalltalk at: #ImageSegment - ifPresent: [:theClass | theClass reclaimObsoleteSegmentFiles]]] ifFalse: [resuming := false]. quit & (resuming == false) ifTrue: [ exitCode ifNil: [ self quitPrimitive ] ifNotNil: [ self quitPrimitive: exitCode ] ]. Cursor normal show. Smalltalk setGCParameters. resuming == true ifTrue: [Smalltalk clearExternalObjects]. Smalltalk processStartUpList: resuming == true. resuming == true ifTrue:[ self setPlatformPreferences. self recordStartupStamp]. Project current wakeUpTopWindow. "Now it's time to raise an error" resuming == nil ifTrue: [self error:'Failed to write image file (disk full?)']. ^ resuming!
Item was changed: ----- Method: SmartRefStream>>reshapedClassesIn: (in category 'import image segment') ----- reshapedClassesIn: outPointers "Look for classes in the outPointer array that have changed shape. Make a fake class for the old shape. Return a dictionary mapping Fake classes to Real classes. Substitute fake classes for real ones in outPointers."
| mapFakeClassesToReal |
self flag: #bobconv.
mapFakeClassesToReal := IdentityDictionary new. outPointers withIndexDo: [:outp :ind | | originalName fakeCls | outp isBehavior ifTrue: [ + originalName := renamed keyAtValue: outp name + ifAbsent: [renamedConv at: ind ifAbsent: [outp name]]. - originalName := renamedConv at: ind ifAbsent: [outp name]. "in DiskProxy>>comeFullyUpOnReload: we saved the name at the index" fakeCls := self mapClass: outp origName: originalName. fakeCls == outp ifFalse: [ mapFakeClassesToReal at: fakeCls put: outp. outPointers at: ind put: fakeCls]]]. ^ mapFakeClassesToReal!