Squeak-dev July 2017

squeak-dev@lists.squeakfoundation.org

28 participants
70 discussions

The Trunk: EToys-eem.303.mcz
by commits＠source.squeak.org 03 Jul '17

03 Jul '17

Eliot Miranda uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-eem.303.mcz ==================== Summary ==================== Name: EToys-eem.303 Author: eem Time: 3 July 2017, 4:16:51.503353 pm UUID: 98b26648-e522-49a7-98db-0d8ce56f9c70 Ancestors: EToys-mt.302 Use NativeImageSegment to compute rootsIncludingPlayers. =============== Diff against EToys-mt.302 =============== Item was changed: ----- Method: Project>>okToChangeSilently (in category '*Etoys-Squeakland-release') ----- okToChangeSilently "Answer whether the window in which the project is housed can be dismissed -- which is destructive. We never clobber a project without confirmation" | ok is list | self subProjects size > 0 ifTrue: [^ false]. ok := world isMorph not and: [world scheduledControllers size <= 1]. ok ifFalse: [self isMorphic ifTrue: [self parent == CurrentProject ifFalse: [^ true]]]. "view from elsewhere. just delete it." ok := true. ok ifFalse: [^ false]. world isMorph ifTrue: [Smalltalk at: #WonderlandCameraMorph ifPresent:[:aClass | world submorphs do: "special release for wonderlands" [:m | (m isKindOf: aClass) and: [m getWonderland release]]]. "Remove Player classes and metaclasses owned by project" + is := NativeImageSegment new arrayOfRoots: {self}. - is := ImageSegment new arrayOfRoots: (Array with: self). (list := is rootsIncludingPlayers) ifNotNil: [list do: [:playerCls | (playerCls respondsTo: #isMeta) ifTrue: [playerCls isMeta ifFalse: [playerCls removeFromSystemUnlogged]]]]]. self removeChangeSetIfPossible. "do this last since it will render project inaccessible to #allProjects and their ilk" ProjectHistory forget: self. Project deletingProject: self. ^ true !

1 0

The Trunk: Morphic-eem.1345.mcz
by commits＠source.squeak.org 03 Jul '17

03 Jul '17

Eliot Miranda uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-eem.1345.mcz ==================== Summary ==================== Name: Morphic-eem.1345 Author: eem Time: 3 July 2017, 4:14:13.779912 pm UUID: e82ec701-a0a6-4fc5-926b-0c2d38894309 Ancestors: Morphic-eem.1344 Use the abstract class-side interface for image segment use now that we have both LegacyImageSegment and NativeImageSegment. =============== Diff against Morphic-eem.1344 =============== Item was changed: ----- Method: MorphicProject>>exportSegmentWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') ----- exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory withoutInteraction: noInteraction "Store my project out on the disk as an *exported* ImageSegment. All outPointers will be in a form that can be resolved in the target image. Name it <project name>.extSeg. Whatdo we do about subProjects, especially if they are out as local image segments? Force them to come in? Player classes are included automatically." | is str ans revertSeg roots holder collector fd mgr stacks | "Files out a changeSet first, so that a project can contain its own classes" world ifNil: [^ false]. world presenter ifNil: [^ false]. ScrapBook default emptyScrapBook. world cleanUpReferences. world currentHand pasteBuffer: nil. "don't write the paste buffer." world currentHand mouseOverHandler initialize. "forget about any references here" "Display checkCurrentHandForObjectToPaste." Command initialize. world clearCommandHistory. world fullReleaseCachedState; releaseViewers. world cleanseStepList. world localFlapTabs size = world flapTabs size ifFalse: [ noInteraction ifTrue: [^ false]. self error: 'Still holding onto Global flaps']. world releaseSqueakPages. Smalltalk at: #ScriptEditorMorph ifPresent: [:s | s writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false])]. holder := Project allProjects. "force them in to outPointers, where DiskProxys are made" "Just export me, not my previous version" revertSeg := self parameterAt: #revertToMe. self removeParameter: #revertToMe. roots := OrderedCollection new. roots add: self; add: world; add: transcript; add: aChangeSetOrNil; add: thumbnail; add: world activeHand. "; addAll: classList; addAll: (classList collect: [:cls | cls class])" roots := roots reject: [ :x | x isNil]. "early saves may not have active hand or thumbnail" fd := aDirectory directoryNamed: self resourceDirectoryName. fd assureExistence. "Clean up resource references before writing out" mgr := self resourceManager. self resourceManager: nil. ResourceCollector current: ResourceCollector new. ResourceCollector current localDirectory: fd. ResourceCollector current baseUrl: self resourceUrl. ResourceCollector current initializeFrom: mgr. ProgressNotification signal: '2:findingResources' extra: '(collecting resources...)' translated. "Must activate old world because this is run at #armsLength. Otherwise references to ActiveWorld, ActiveHand, or ActiveEvent will not be captured correctly if referenced from blocks or user code." world becomeActiveDuring:[ + is := ImageSegment copySmartRootsExport: roots asArray. - is := ImageSegment new copySmartRootsExport: roots asArray. "old way was (is := ImageSegment new copyFromRootsForExport: roots asArray)" ]. self resourceManager: mgr. collector := ResourceCollector current. ResourceCollector current: nil. ProgressNotification signal: '2:foundResources' extra: ''. is state = #tooBig ifTrue: [ collector replaceAll. ^ false]. str := ''. "considered legal to save a project that has never been entered" (is outPointers includes: world) ifTrue: [ str := str, '\Project''s own world is not in the segment.' translated withCRs]. str isEmpty ifFalse: [ ans := UIManager default chooseFrom: { 'Do not write file' translated. 'Write file anyway' translated. 'Debug' translated. } title: str. ans = 1 ifTrue: [ revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. collector replaceAll. ^ false]. ans = 3 ifTrue: [ collector replaceAll. self halt: 'Segment not written' translated]]. stacks := is findStacks. is writeForExportWithSources: aFileName inDirectory: fd changeSet: aChangeSetOrNil. SecurityManager default signFile: aFileName directory: fd. "Compress all files and update check sums" collector forgetObsolete. self storeResourceList: collector in: fd. self storeHtmlPageIn: fd. self storeManifestFileIn: fd. self writeStackText: stacks in: fd registerIn: collector. "local proj.005.myStack.t" self compressFilesIn: fd to: aFileName in: aDirectory resources: collector. "also deletes the resource directory" "Now update everything that we know about" mgr updateResourcesFrom: collector. revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. holder. collector replaceAll. world flapTabs do: [:ft | (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]]. is arrayOfRoots do: [:obj | obj isScriptEditorMorph ifTrue: [obj unhibernate]]. ^ true ! Item was changed: ----- Method: MorphicProject>>storeSegment (in category 'file in/out') ----- storeSegment "Store my project out on the disk as an ImageSegment. Keep the outPointers in memory. Name it <project name>.seg. *** Caller must be holding (Project alInstances) to keep subprojects from going out. ***" | is sizeHint | (World == world) ifTrue: [^ false]. "self inform: 'Can''t send the current world out'." world isInMemory ifFalse: [^ false]. "already done" world ifNil: [^ false]. world presenter ifNil: [^ false]. ScrapBook default emptyScrapBook. World checkCurrentHandForObjectToPaste. world releaseSqueakPages. sizeHint := self projectParameters at: #segmentSize ifAbsent: [0]. + is := ImageSegment + copyFromRootsLocalFileFor: {world presenter. world} "world, and all Players" + sizeHint: sizeHint. - is := ImageSegment new copyFromRootsLocalFileFor: - (Array with: world presenter with: world) "world, and all Players" - sizeHint: sizeHint. is state = #tooBig ifTrue: [^ false]. is segment size < 2000 ifTrue: ["debugging" Transcript show: self name, ' only ', is segment size printString, 'bytes in Segment.'; cr]. self projectParameters at: #segmentSize put: is segment size. is extract; writeToFile: self name. + ^ true! - ^ true - ! Item was changed: ----- Method: MorphicProject>>storeSegmentNoFile (in category 'file in/out') ----- storeSegmentNoFile "For testing. Make an ImageSegment. Keep the outPointers in memory. Also useful if you want to enumerate the objects in the segment afterwards (allObjectsDo:)" | is | (World == world) ifTrue: [^ self]. " inform: 'Can''t send the current world out'." world isInMemory ifFalse: [^ self]. "already done" world ifNil: [^ self]. world presenter ifNil: [^ self]. "Do this on project enter" World flapTabs do: [:ft | ft referent adaptToWorld: World]. "Hack to keep the Menu flap from pointing at my project" "Preferences setPreference: #useGlobalFlaps toValue: false." "Utilities globalFlapTabsIfAny do: [:aFlapTab | Utilities removeFlapTab: aFlapTab keepInList: false]. Utilities clobberFlapTabList. " "project world deleteAllFlapArtifacts." "self currentWorld deleteAllFlapArtifacts. " ScrapBook default emptyScrapBook. World checkCurrentHandForObjectToPaste2. + is := ImageSegment + copyFromRootsLocalFileFor: {world presenter. world} "world, and all Players" + sizeHint: 0. - is := ImageSegment new copyFromRootsLocalFileFor: - (Array with: world presenter with: world) "world, and all Players" - sizeHint: 0. is segment size < 800 ifTrue: ["debugging" Transcript show: self name, ' did not get enough objects'; cr. ^ Beeper beep]. is extract. + "is instVarAt: 2 put: is segment clone." "different memory"! - "is instVarAt: 2 put: is segment clone." "different memory" - !

1 0

The Trunk: Tests-eem.379.mcz
by commits＠source.squeak.org 03 Jul '17

03 Jul '17

Eliot Miranda uploaded a new version of Tests to project The Trunk: http://source.squeak.org/trunk/Tests-eem.379.mcz ==================== Summary ==================== Name: Tests-eem.379 Author: eem Time: 3 July 2017, 4:13:10.068801 pm UUID: cdac3950-d5ff-488a-b17c-a733bd79b74e Ancestors: Tests-eem.378 Use the abstract class-side interface for image segment use now that we have both LegacyImageSegment and NativeImageSegment. =============== Diff against Tests-eem.378 =============== Item was changed: ----- Method: BitmapStreamTests>>validateImageSegment (in category 'private') ----- validateImageSegment "array is set up with an array." | other filename | filename := 'bitmapStreamTest.extSeg'. FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. + (ImageSegment copyFromRootsForExport: {array}) - (ImageSegment new copyFromRootsForExport: (Array with: array)) writeForExport: filename. other := (FileDirectory default readOnlyFileNamed: filename) fileInObjectAndCode. self assert: array = other originalRoots first. "clean up disk" FileDirectory default deleteFileNamed: filename ifAbsent: [ ]! Item was changed: ----- Method: ImageSegmentTest>>testImageSegmentsShouldBeWritableToaFile (in category 'testing') ----- testImageSegmentsShouldBeWritableToaFile "This should not throw an exception" | classes | classes := UIManager subclasses reject: [:sc| sc isActiveManager]. + NativeImageSegment new - ImageSegment new copyFromRoots: classes asArray sizeHint: 100; extract; writeToFile: 'InactiveUIManagers'; yourself. "TODO: write assertions showing that something meaningful actually happened." "now bring them back in again" classes do: [:ea| ea new]!

1 0

The Trunk: System-eem.957.mcz
by commits＠source.squeak.org 03 Jul '17

03 Jul '17

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-eem.957.mcz ==================== Summary ==================== Name: System-eem.957 Author: eem Time: 3 July 2017, 4:07:46.640889 pm UUID: 664700ec-a104-46ba-99cf-e70dcdc6ea10 Ancestors: System-pre.956 Rstore the ImageSegment reading & writing facilities. Refactor ImageSegment into ImageSegment, LegacyImageSegment (the new all-Smalltalk v3 loading code) and NativeImageSegment (the existing implementation dependent on ObjectMemory primitives). Provide ImageSegment class-side methods for reading to insulate clients from the subclasses. The space analysis that decoded the image segment bits needs to be rewritten for Spur. See senders of errorRewriteForSpur. Nuke compactClassesArray usage from NativeImageSegment, and indeed from SmalltalkImage>>cleanUp. The ImageSegmentTests pass but the BitmapStreamTests do not. Needs fiurther investigation but should be easy to fix given that the ImageSegmentTests pass. =============== Diff against System-pre.956 =============== Item was changed: ----- Method: CodeLoader class>>exportCodeSegment:classes:keepSource: (in category 'utilities') ----- exportCodeSegment: exportName classes: aClassList keepSource: keepSources "Code for writing out a specific category of classes as an external image segment. Perhaps this should be a method." | is oldMethods newMethods classList symbolHolder fileName | keepSources ifTrue: [ self confirm: 'We are going to abandon sources. Quit without saving after this has run.' orCancel: [^self]]. classList := aClassList asArray. "Strong pointers to symbols" symbolHolder := Symbol allSymbols. oldMethods := OrderedCollection new: classList size * 150. newMethods := OrderedCollection new: classList size * 150. keepSources ifTrue: [ classList do: [:cl | cl selectorsAndMethodsDo: [:selector :m | | oldCodeString methodNode | m fileIndex > 0 ifTrue: [oldCodeString := cl sourceCodeAt: selector. methodNode := cl newCompiler parse: oldCodeString in: cl notifying: nil. oldMethods addLast: m. newMethods addLast: (m copyWithTempsFromMethodNode: methodNode)]]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. oldMethods := newMethods := nil. Smalltalk garbageCollect. + is := ImageSegment copyFromRootsForExport: classList. "Classes and MetaClasses" - is := ImageSegment new copyFromRootsForExport: classList. "Classes and MetaClasses" fileName := FileDirectory fileName: exportName extension: ImageSegment fileExtension. is writeForExport: fileName. self compressFileNamed: fileName ! Item was changed: ----- Method: DiskProxy>>comeFullyUpOnReload: (in category 'i/o') ----- comeFullyUpOnReload: smartRefStream "Internalize myself into a fully alive object after raw loading from a DataStream. (See my class comment.) DataStream will substitute the object from this eval for the DiskProxy." | globalObj symbol pr nn arrayIndex env | symbol := globalObjectName. "See if class is mapped to another name" + (smartRefStream respondsTo: #renamed) ifTrue: + [| maybeReadDataFromContext maybeReadArrayContext | + "Ugh; so ugly and brittle. If there were pragmas in the relevant methods we could search, etc. eem 7/3/2017 15:54" + maybeReadArrayContext := thisContext sender sender sender sender. + maybeReadDataFromContext := maybeReadArrayContext sender sender sender sender. - (smartRefStream respondsTo: #renamed) ifTrue: [ "If in outPointers in an ImageSegment, remember original class name. + See mapClass:installIn:. Would be lost otherwise." "Anyone know where mapClass:installIn: is/was? eem 7/3/2017 15:55" + (maybeReadDataFromContext method selector == #readDataFrom:size: + and: [maybeReadDataFromContext receiver class == NativeImageSegment + and: [maybeReadArrayContext method == (DataStream compiledMethodAt: #readArray)]]) ifTrue: + [arrayIndex := maybeReadArrayContext tempAt: 4. + "index var in readArray. Later safer to find i on stack of context." + smartRefStream renamedConv at: arrayIndex put: symbol]. "save original name" - See mapClass:installIn:. Would be lost otherwise." - ((thisContext sender sender sender sender sender sender - sender sender receiver class == ImageSegment) and: [ - thisContext sender sender sender sender method == - (DataStream compiledMethodAt: #readArray)]) ifTrue: [ - arrayIndex := (thisContext sender sender sender sender) tempAt: 4. - "index var in readArray. Later safer to find i on stack of context." - smartRefStream renamedConv at: arrayIndex put: symbol]. "save original name" symbol := smartRefStream renamed at: symbol ifAbsent: [symbol]]. "map" env := Environment current. globalObj := env valueOf: symbol ifAbsent: [ preSelector == nil & (constructorSelector = #yourself) ifTrue: [ Transcript cr; show: symbol, ' is undeclared.'. env undeclare: symbol. ^ nil]. ^ self error: 'Global "', symbol, '" not found']. ((symbol == #World) and: [Smalltalk isMorphic not]) ifTrue: [ self inform: 'These objects will work better if opened in a Morphic World. Dismiss and reopen all menus.']. preSelector ifNotNil: [ Symbol hasInterned: preSelector ifTrue: [:selector | [globalObj := globalObj perform: selector] on: Error do: [:ex | ex messageText = 'key not found' ifTrue: [^ nil]. ^ ex signal]] ]. symbol == #Project ifTrue: [ (constructorSelector = #fromUrl:) ifTrue: [ nn := (constructorArgs first findTokens: '/') last. nn := (nn findTokens: '.|') first. pr := Project named: nn. ^ pr ifNil: [self] ifNotNil: [pr]]. pr := globalObj perform: constructorSelector withArguments: constructorArgs. ^ pr ifNil: [self] ifNotNil: [pr]]. "keep the Proxy if Project does not exist" constructorSelector ifNil: [^ globalObj]. Symbol hasInterned: constructorSelector ifTrue: [:selector | [^ globalObj perform: selector withArguments: constructorArgs] on: Error do: [:ex | ex messageText = 'key not found' ifTrue: [^ nil]. ^ ex signal] ]. "args not checked against Renamed" ^ nil "was not in proper form"! Item was changed: Object subclass: #ImageSegment instanceVariableNames: 'arrayOfRoots segment outPointers state segmentName fileName userRootCnt renamedClasses' classVariableNames: 'RecentlyRenamedClasses' poolDictionaries: '' category: 'System-Object Storage'! + !ImageSegment commentStamp: 'eem 7/3/2017 13:44' prior: 0! - !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 --- 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. + + I have two concrete subclasses, NativeImageSegment and + LegacyImageSegment. NativeImageSegment uses a pair of primitives, + one to create a segment and one to load it. LegacyImageSegment + implements the load primitive for the older Squeak memory format + (sometimes called "v3") but uses pure Smalltalk code. + 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 := 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 added: + ----- Method: ImageSegment class>>copyFromRootsForExport: (in category 'fileIn/Out') ----- + 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." + ^NativeImageSegment new copyFromRootsForExport: rootArray! Item was added: + ----- Method: ImageSegment class>>copyFromRootsLocalFileFor:sizeHint: (in category 'fileIn/Out') ----- + copyFromRootsLocalFileFor: rootArray sizeHint: segSize + "If the roots include a World, add its Player classes to the roots." + ^NativeImageSegment new copyFromRootsLocalFileFor: rootArray sizeHint: segSize! Item was added: + ----- Method: ImageSegment class>>copySmartRootsExport: (in category 'fileIn/Out') ----- + 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." + ^NativeImageSegment new copySmartRootsExport: rootArray ! Item was changed: ----- Method: ImageSegment>>comeFullyUpOnReload: (in category 'fileIn') ----- comeFullyUpOnReload: smartRefStream "fix up the objects in the segment that changed size. An object in the segment is the wrong size for the modern version of the class. Construct a fake class that is the old size. Replace the modern class with the old one in outPointers. Load the segment. Traverse the instances, making new instances by copying fields, and running conversion messages. Keep the new instances. Bulk forward become the old to the new. Let go of the fake objects and classes. After the install (below), arrayOfRoots is filled in. Globalize new classes. Caller may want to do some special install on certain objects in arrayOfRoots. May want to write the segment out to disk in its new form." | mapFakeClassesToReal receiverClasses rootsToUnhiberhate myProject existing forgetDoItsClass endianness | forgetDoItsClass := Set new. RecentlyRenamedClasses := nil. "in case old data hanging around" mapFakeClassesToReal := smartRefStream reshapedClassesIn: outPointers. "Dictionary of just the ones that change shape. Substitute them in outPointers." self fixCapitalizationOfSymbols. + endianness := (segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]. + segment := self loadSegmentFrom: segment outPointers: outPointers. - endianness := (segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]. - segment := ImageSegmentLoader new loadSegmentFrom: segment outPointers: outPointers. arrayOfRoots := segment first. mapFakeClassesToReal isEmpty ifFalse: [ self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream ]. "When a Project is stored, arrayOfRoots has all objects in the project, except those in outPointers" arrayOfRoots do: [:importedObject | ((importedObject isMemberOf: WideString) or: [importedObject isMemberOf: WideSymbol]) ifTrue: [ importedObject mutateJISX0208StringToUnicode. importedObject class = WideSymbol ifTrue: [ "self halt." Symbol hasInterned: importedObject asString ifTrue: [:multiSymbol | multiSymbol == importedObject ifFalse: [ importedObject becomeForward: multiSymbol. ]. ]. ]. ]. (importedObject isMemberOf: TTCFontSet) ifTrue: [ existing := TTCFontSet familyName: importedObject familyName pointSize: importedObject pointSize. "supplies default" existing == importedObject ifFalse: [importedObject becomeForward: existing]. ]. ]. receiverClasses := self restoreEndianness: endianness ~~ Smalltalk endianness. "rehash sets" smartRefStream checkFatalReshape: receiverClasses. "Classes in this segment." arrayOfRoots do: [:importedObject | importedObject class class == Metaclass ifTrue: [forgetDoItsClass add: importedObject. self declare: importedObject]]. rootsToUnhiberhate := OrderedCollection new. arrayOfRoots do: [:importedObject | ((importedObject isMemberOf: ScriptEditorMorph) or: [(importedObject isKindOf: TileMorph) or: [(importedObject isMemberOf: ScriptingTileHolder) or: [importedObject isKindOf: CompoundTileMorph]]]) ifTrue: [ rootsToUnhiberhate add: importedObject ]. (importedObject isMemberOf: Project) ifTrue: [ myProject := importedObject. importedObject ensureChangeSetNameUnique. Project addingProject: importedObject. importedObject restoreReferences. self dependentsRestore: importedObject. ScriptEditorMorph writingUniversalTiles: ((importedObject projectPreferenceAt: #universalTiles) ifNil: [false])]]. myProject ifNotNil: [ myProject world setProperty: #thingsToUnhibernate toValue: rootsToUnhiberhate asArray. ]. mapFakeClassesToReal isEmpty ifFalse: [ mapFakeClassesToReal keysAndValuesDo: [:aFake :aReal | aFake removeFromSystemUnlogged. aFake becomeForward: aReal]. SystemOrganization removeEmptyCategories]. forgetDoItsClass do: [:c | c forgetDoIts]. "^ self" ! Item was added: + ----- Method: ImageSegment>>loadSegmentFrom:outPointers: (in category 'read/write segment') ----- + loadSegmentFrom: segment outPointers: outPointers + "Attempt to load the segment into memory (reify the objects in segment + as real objects), using outPointers to bind references to objects not in the + segment. Answer a collection of all the objects in the segment." + self subclassResponsibility! Item was changed: Object subclass: #ImageSegmentLoader instanceVariableNames: 'segment outPointers oopMap position' classVariableNames: 'BytesInHeader CompactClasses HeaderTypeClass HeaderTypeFree HeaderTypeMask HeaderTypeShort HeaderTypeSizeAndClass' poolDictionaries: '' category: 'System-Object Storage'! + !ImageSegmentLoader commentStamp: 'eem 7/3/2017 13:40' prior: 0! + This class is used to load objects from an ImageSegment that is incompatible with the current VM (see LegacyImageSegment>>loadSegmentFrom:outPointers:).! - !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: + ImageSegment subclass: #LegacyImageSegment + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'System-Object Storage'! + + !LegacyImageSegment commentStamp: 'eem 7/3/2017 13:39' prior: 0! + ImageSegment is used to import old (interpreter VM era) projects into + new images. Instead of a VM primitive it uses LegacyImageSegmentLoader + to load objects from the segment. There are no methods for writing segments + in the legacy format. + + The original ImageSegment scheme 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.! Item was added: + ----- Method: LegacyImageSegment>>ifOutPointer:thenAllObjectsDo: (in category 'instance change shape') ----- + ifOutPointer: anObject thenAllObjectsDo: aBlock + "Compatibility with NativeImageSegment (see e.g. MorphicProject class>>releaseProjectReferences:). + Do nothing since LegacyImageSegments are load-only. (Not sure if this is right, eem 7/3/2017 15:19)"! Item was added: + ----- Method: LegacyImageSegment>>loadSegmentFrom:outPointers: (in category 'read/write segment primitives') ----- + loadSegmentFrom: segment outPointers: outPointers + "Attempt to load the segment into memory (reify the objects in segment + as real objects), using outPointers to bind references to objects not in the + segment. Answer a collection of all the objects in the segment." + ^ImageSegmentLoader new loadSegmentFrom: segment outPointers: outPointers! Item was added: + ImageSegment subclass: #NativeImageSegment + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'System-Object Storage'! + + !NativeImageSegment commentStamp: 'eem 7/3/2017 13:52' prior: 0! + NativeImageSegment is used to save and restore projects. It uses + one primitive to create a segment (a WordArray) whose contents + are the objects in the project in the same format as they appear in + the VM's heap. It uses another primitive to convert a segment back + into objects.! Item was added: + ----- Method: NativeImageSegment class>>activeClasses (in category 'testing') ----- + activeClasses "NativeImageSegment 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 added: + ----- Method: NativeImageSegment class>>activeClassesByCategory (in category 'testing') ----- + activeClassesByCategory "NativeImageSegment 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 + " + NativeImageSegment discoverActiveClasses <-- do it + -- do something typical -- + NativeImageSegment activeClassesByCategory <-- inspect it + "! Item was added: + ----- Method: NativeImageSegment class>>compressedFileExtension (in category 'accessing') ----- + compressedFileExtension + ^'sqz'! Item was added: + ----- Method: NativeImageSegment class>>discoverActiveClasses (in category 'testing') ----- + discoverActiveClasses "NativeImageSegment 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]]. + " + NativeImageSegment discoverActiveClasses. + -- do something typical -- + PopUpMenu notify: NativeImageSegment activeClasses size printString , ' classes were active out of ' , + Smalltalk allClasses size printString. + "! Item was added: + ----- Method: NativeImageSegment class>>fileExtension (in category 'accessing') ----- + fileExtension + ^'extSeg'! Item was added: + ----- Method: NativeImageSegment 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 added: + ----- Method: NativeImageSegment class>>reclaimObsoleteSegmentFiles (in category 'fileIn/Out') ----- + reclaimObsoleteSegmentFiles "NativeImageSegment 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" + NativeImageSegment 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 added: + ----- Method: NativeImageSegment 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 added: + ----- Method: NativeImageSegment 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) NativeImageSegmentRootStub 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 added: + ----- Method: NativeImageSegment 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 added: + ----- Method: NativeImageSegment class>>swapOutInactiveClasses (in category 'testing') ----- + swapOutInactiveClasses "NativeImageSegment swapOutInactiveClasses" + "Make up segments by grouping unused classes by system category. + Read about, and execute discoverActiveClasses, and THEN execute this one." + + | unused groups | + NativeImageSegment 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: + [(NativeImageSegment new copyFromRoots: roots sizeHint: 0) extract; + writeToFile: cat]. + Transcript cr; print: Smalltalk bytesLeft "does a gc"; endEntry]! Item was added: + ----- Method: NativeImageSegment class>>swapOutProjects (in category 'testing') ----- + swapOutProjects "NativeImageSegment 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. + (NativeImageSegment 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 added: + ----- Method: NativeImageSegment class>>testClassFaultOn: (in category 'testing') ----- + testClassFaultOn: someClass "NativeImageSegment 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." + + (NativeImageSegment new copyFromRoots: (Array with: someClass with: someClass class) + sizeHint: 0) extract; writeToFile: 'test'.! Item was added: + ----- Method: NativeImageSegment 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 added: + ----- Method: NativeImageSegment>>aComment (in category 'compact classes') ----- + aComment + "Spur does not use compact classes, so an effort has been made to excise their use from the code. Thew previous comment was: + + 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 added: + ----- Method: NativeImageSegment>>acceptSingleMethodSource: (in category 'fileIn/Out') ----- + acceptSingleMethodSource: aDictionary + + | oldClassInfo oldClassName ismeta newName actualClass selector | + oldClassInfo := (aDictionary at: #oldClassName) findTokens: ' '. "'Class' or 'Class class'" + oldClassName := oldClassInfo first asSymbol. + ismeta := oldClassInfo size > 1. + + "must use class var since we may not be the same guy who did the initial work" + + newName := RecentlyRenamedClasses ifNil: [ + oldClassName + ] ifNotNil: [ + RecentlyRenamedClasses at: oldClassName ifAbsent: [oldClassName] + ]. + actualClass := Smalltalk at: newName. + ismeta ifTrue: [actualClass := actualClass class]. + selector := actualClass newParser parseSelector: (aDictionary at: #methodText). + (actualClass compiledMethodAt: selector ifAbsent: [^self "hosed input"]) + putSource: (aDictionary at: #methodText) + fromParseNode: nil + class: actualClass + category: (aDictionary at: #category) + withStamp: (aDictionary at: #changeStamp) + inFile: 2 + priorMethod: nil. + ! Item was added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>classNameAt: (in category 'statistics') ----- + classNameAt: index + | ccIndex | + self errorRewriteForSpur. + 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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 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" + "Zap sender of a homeContext. Can't send live stacks out." "Why not? eem 7/3/2017 15:31" + 1 to: outPointers size do: [:ii | | outPointer | + outPointer := outPointers at: ii. + (outPointer isBlock + or: [outPointer isContext]) ifTrue: [outPointers at: ii put: nil]]. + symbolHolder size "Keep reference to symbolHolder until the last"! Item was added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 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. "Allow dummy to be GC'ed below (bytesLeft)." + naughtyBlocks := arrayOfRoots select: [ :each | + each isContext 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 up later if needed)" + sizeHint := (Smalltalk bytesLeft // 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" + 1 to: outPointers size do: [:ii | | outPointer | + outPointer := outPointers at: ii. + (outPointer isBlock + or: [outPointer isContext]) ifTrue: [outPointers at: ii put: nil]. + "substitute new object in outPointers" + (replacements includesKey: outPointer) ifTrue: + [outPointers at: ii put: (replacements at: outPointer)]]. + proj ifNotNil: [self dependentsCancel: proj]. + symbolHolder. "hold onto symbolHolder until the last."! Item was added: + ----- Method: NativeImageSegment>>deepCopyTest: (in category 'testing') ----- + deepCopyTest: aRootArray + "NativeImageSegment new deepCopyTest: Morph withAllSubclasses asArray" + "Project allInstances do: + [:p | p == Project current ifFalse: + [Transcript cr; cr; nextPutAll: p name. + NativeImageSegment 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 | NativeImageSegment new deepCopyTest: (Array with: m with: m class)] + "! Item was added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 | + self errorRewriteForSpur. + 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 added: + ----- Method: NativeImageSegment>>endianness (in category 'fileIn/Out') ----- + endianness + "Return which endian kind the incoming segment came from" + + segment class isBits ifFalse: + ["Hope that primitive 98 did the right thing - anyway, we lost information about endianness, so pretend we share the image's endianness." + ^Smalltalk endianness]. + ^(segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]! Item was added: + ----- Method: NativeImageSegment>>errorRewriteForSpur (in category 'error handling') ----- + errorRewriteForSpur + self error: 'the method must be rewritten for Spur'! Item was added: + ----- Method: NativeImageSegment>>errorWrongState (in category 'testing') ----- + errorWrongState + + ^ self error: 'wrong state'! Item was added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>extractThenInstall (in category 'read/write segment') ----- + extractThenInstall + "For testing only" + + | allObjectsInSegment newRoots | + state = #activeCopy ifFalse: [self errorWrongState]. + arrayOfRoots elementsForwardIdentityTo: + (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]). + state := #active. + allObjectsInSegment := self loadSegmentFrom: segment outPointers: outPointers. + newRoots := allObjectsInSegment first. + state := #inactive. + arrayOfRoots elementsForwardIdentityTo: newRoots.! Item was added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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." + + | allObjectsInSegment newRoots | + state = #onFile ifTrue: [self readFromFile]. + state = #onFileWithSymbols ifTrue: + [self readFromFileWithSymbols]. + (state = #active) | (state = #imported) ifFalse: [self errorWrongState]. + allObjectsInSegment := self loadSegmentFrom: segment outPointers: outPointers. + newRoots := allObjectsInSegment first. + self checkAndReportLoadError. + state = #imported "just came in from exported file" + ifTrue: [arrayOfRoots := newRoots] + ifFalse: [arrayOfRoots elementsForwardIdentityTo: newRoots]. + state := #inactive. + Beeper beepPrimitive! Item was added: + ----- Method: NativeImageSegment>>isOnFile (in category 'testing') ----- + isOnFile + ^ state == #onFile! Item was added: + ----- Method: NativeImageSegment>>loadSegmentFrom:outPointers: (in category 'read/write segment 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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 | + self errorRewriteForSpur. + 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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>outPointers (in category 'access') ----- + outPointers + ^ outPointers! Item was added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>restoreEndianness (in category 'fileIn/Out') ----- + restoreEndianness + ^self restoreEndianness: self endianness ~~ Smalltalk endianness! Item was added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>scanFrom: (in category 'fileIn/Out') ----- + scanFrom: aStream + "Move source code from a fileIn to the changes file for classes in an ImageSegment. Do not compile the methods. They already came in via the image segment. After the ImageSegment in the file, !!ImageSegment new!! captures control, and scanFrom: is called." + | val chunk | + + [aStream atEnd] whileFalse: + [aStream skipSeparators. + val := (aStream peekFor: $!!) + ifTrue: ["Move (aStream nextChunk), find the method or class + comment, and install the file location bytes" + (Compiler evaluate: aStream nextChunk logged: false) + scanFromNoCompile: aStream forSegment: self] + ifFalse: [chunk := aStream nextChunk. + aStream checkForPreamble: chunk. + Compiler evaluate: chunk logged: true]. + aStream skipStyleChunk]. + "regular fileIn will close the file" + ^ val! Item was added: + ----- Method: NativeImageSegment>>scanFrom:environment: (in category 'fileIn/Out') ----- + scanFrom: aStream environment: anEnvironment + ^ self scanFrom: aStream! Item was added: + ----- Method: NativeImageSegment>>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 isImmediateClass 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" + 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 added: + ----- Method: NativeImageSegment>>segment (in category 'access') ----- + segment + ^ segment! Item was added: + ----- Method: NativeImageSegment>>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." + + | allObjectsInSegment newRoots | + state = #activeCopy ifFalse: [self errorWrongState]. + allObjectsInSegment := self loadSegmentFrom: segment copy outPointers: outPointers. + newRoots := allObjectsInSegment first. + ^newRoots! Item was added: + ----- Method: NativeImageSegment>>segmentName (in category 'read/write segment') ----- + segmentName + "Return the local file name for this segment." + + ^ segmentName! Item was added: + ----- Method: NativeImageSegment>>segmentName: (in category 'read/write segment') ----- + segmentName: aString + "Local file name for this segment." + + segmentName := aString! Item was added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>state (in category 'access') ----- + state + ^ state! Item was added: + ----- Method: NativeImageSegment>>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 shallowCopy. + 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 added: + ----- Method: NativeImageSegment>>storeSegmentFor:into:outPointers: (in category 'read/write segment 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 in determining 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 or 8, depending on word size). but with the high bit set. + + Note: the first element of the segmentWordArray (and hence the first element of + the Array answered by loadSegmentFrom:outPointers:) is the rootsArray." + + "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 error: ec> "successful completion returns self" + ^nil "failure returns nil"! Item was added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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: '\\!!NativeImageSegment new!!\\' withCRs. + methodsWithSource do: [ :each | + fileStream nextPut: $!!. "try to pacify NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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: '\\!!NativeImageSegment 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 added: + ----- Method: NativeImageSegment>>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: '\\!!NativeImageSegment new!!\\' withCRs. + methodsWithSource do: [ :each | + fileStream nextPut: $!!. "try to pacify NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 added: + ----- Method: NativeImageSegment>>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 changed: ----- Method: SmalltalkImage class>>cleanUp (in category 'class initialization') ----- cleanUp + "Flush caches. This used to flush obsolete classes from the compactClassesArray. But Spur doesn't use compact classes so currently this method is empty."! - "Flush caches" - - Smalltalk removeObsoleteClassesFromCompactClassesArray! Item was removed: - ----- Method: SmalltalkImage>>removeObsoleteClassesFromCompactClassesArray (in category 'housekeeping') ----- - removeObsoleteClassesFromCompactClassesArray - - self compactClassesArray doWithIndex: [ :each :index | - (each notNil and: [ - each isObsolete and: [ - each instanceCount = 0 ] ]) ifTrue: [ - Smalltalk compactClassesArray at: index put: nil ] ].! Item was changed: ----- Method: SmalltalkImage>>saveAsEmbeddedImage (in category 'sources, changes log') ----- saveAsEmbeddedImage "Save the current state of the system as an embedded image" | dir newName newImageName oldImageSegDir haveSegs | dir := FileDirectory default. newName := UIManager default request: 'Select existing VM file' initialAnswer: (FileDirectory localNameFor: ''). newName = '' ifTrue: [^Smalltalk]. newName := FileDirectory baseNameFor: newName asFileName. newImageName := newName. (dir includesKey: newImageName) ifFalse: [^self inform: 'Unable to find name ' , newName , ' Please choose another name.']. haveSegs := false. + Smalltalk at: #NativeImageSegment - Smalltalk at: #ImageSegment ifPresent: [:theClass | (haveSegs := theClass instanceCount ~= 0) ifTrue: [oldImageSegDir := theClass segmentDirectory]]. self logChange: '----SAVEAS (EMBEDDED) ' , newName , '----' , Date dateAndTimeNow printString. self imageName: (dir fullNameFor: newImageName) asSqueakPathName. LastImageName := self imageName. self closeSourceFiles. haveSegs ifTrue: + [Smalltalk at: #NativeImageSegment - [Smalltalk at: #ImageSegment ifPresent: [:theClass | | newImageSegDir | newImageSegDir := theClass segmentDirectory. "create the folder" oldImageSegDir fileNames do: [:theName | "copy all segment files" newImageSegDir copyFileNamed: oldImageSegDir pathName , FileDirectory slash , theName toFileNamed: theName]]]. self snapshot: true andQuit: true embedded: true! Item was changed: ----- Method: SmalltalkImage>>saveImageSegments (in category 'sources, changes log') ----- saveImageSegments | haveSegs oldImageSegDir | haveSegs := false. + Smalltalk at: #NativeImageSegment ifPresent: [:theClass | - Smalltalk at: #ImageSegment ifPresent: [:theClass | (haveSegs := theClass instanceCount ~= 0) ifTrue: [ oldImageSegDir := theClass segmentDirectory]]. haveSegs ifTrue: [ + Smalltalk at: #NativeImageSegment ifPresent: [:theClass | | newImageSegDir | - Smalltalk at: #ImageSegment ifPresent: [:theClass | | newImageSegDir | newImageSegDir := theClass segmentDirectory. "create the folder" oldImageSegDir fileNames do: [:theName | "copy all segment files" | imageSegmentName | imageSegmentName := oldImageSegDir pathName, FileDirectory slash, theName. newImageSegDir copyFileWithoutOverwriteConfirmationNamed: imageSegmentName toFileNamed: theName]]]. !

1 0

The Trunk: WebClient-Core-topa.107.mcz
by commits＠source.squeak.org 03 Jul '17

03 Jul '17

Tobias Pape uploaded a new version of WebClient-Core to project The Trunk: http://source.squeak.org/trunk/WebClient-Core-topa.107.mcz ==================== Summary ==================== Name: WebClient-Core-topa.107 Author: topa Time: 3 July 2017, 5:28:49.566897 pm UUID: c6babbda-f5e2-4d26-a5f1-c73651519b4a Ancestors: WebClient-Core-topa.106 Make sure WebMessage>>getContent respects charset. =============== Diff against WebClient-Core-topa.106 =============== Item was changed: ----- Method: WebMessage>>getContentWithProgress: (in category 'private') ----- getContentWithProgress: progressBlockOrNil "Reads available content and returns it." | length result | length := self contentLength. result := (stream isBinary ifTrue:[ ByteArray ] ifFalse: [ ByteString ]) new: (length ifNil: [ 1000 ]) streamContents: [ :outputStream | self streamFrom: stream to: outputStream size: length progress: progressBlockOrNil ]. + self textConverterForContentType ifNotNil: [:converter | + result := result convertFromWithConverter: converter]. (self headerAt: 'content-encoding') = 'gzip' ifFalse: [ ^result ]. ^(GZipReadStream on: result) upToEnd ! Item was added: + ----- Method: WebMessage>>textConverterForContentType (in category 'accessing') ----- + textConverterForContentType + + | index contentType | + contentType := self contentType. + contentType size < 8 ifTrue: [ ^nil ]. + index := contentType findString: 'charset=' startingAt: 1 caseSensitive: false. + index = 0 ifTrue: [ ^nil ]. + ^TextConverter newForEncoding: (contentType allButFirst: index + 7) "'charset=' size - 1"! Item was removed: - ----- Method: WebRequest>>textConverterForContentType (in category 'accessing') ----- - textConverterForContentType - - | index contentType | - contentType := self contentType. - contentType size < 8 ifTrue: [ ^nil ]. - index := contentType findString: 'charset=' startingAt: 1 caseSensitive: false. - index = 0 ifTrue: [ ^nil ]. - ^TextConverter newForEncoding: (contentType allButFirst: index + 7) "'charset=' size - 1"!

1 0

The Trunk: WebClient-Core-topa.107.mcz
by commits＠source.squeak.org 03 Jul '17

03 Jul '17

1 0

The Trunk: WebClient-Tests-topa.51.mcz
by commits＠source.squeak.org 03 Jul '17

03 Jul '17

Tobias Pape uploaded a new version of WebClient-Tests to project The Trunk: http://source.squeak.org/trunk/WebClient-Tests-topa.51.mcz ==================== Summary ==================== Name: WebClient-Tests-topa.51 Author: topa Time: 3 July 2017, 5:27:47.053581 pm UUID: ff869e77-50d0-4379-af4e-af233785ee01 Ancestors: WebClient-Tests-topa.50 Make sure WebMessage>>getContent respects charset. =============== Diff against WebClient-Tests-topa.50 =============== Item was added: + ----- Method: WebClientServerTest>>testContentEncoding (in category 'tests - misc') ----- + testContentEncoding + "Test encoding detection" + | resp expected | + expected := '«garçon Léon»'. + #( + 'latin-1' #[171 103 97 114 231 111 110 32 76 233 111 110 187] + 'macroman' #[199 103 97 114 141 111 110 32 76 142 111 110 200] + 'utf-8' #[194 171 103 97 114 195 167 111 110 32 76 195 169 111 110 194 187] + ) pairsDo: [:name :bytes | + server addService: '/testcontent', name action:[:req|req send200Response: bytes asString contentType: 'text/plain; charset=', name]. + resp := WebClient httpGet: self localHostUrl, '/testcontent', name. + self assert: 200 equals: resp code. + self assert: expected equals: resp content]. + !

1 0

The Trunk: WebClient-Tests-topa.50.mcz
by commits＠source.squeak.org 03 Jul '17

03 Jul '17

Tobias Pape uploaded a new version of WebClient-Tests to project The Trunk: http://source.squeak.org/trunk/WebClient-Tests-topa.50.mcz ==================== Summary ==================== Name: WebClient-Tests-topa.50 Author: topa Time: 3 July 2017, 4:14:20.605266 pm UUID: 2acac067-6f72-4b30-b000-689349b5733b Ancestors: WebClient-Tests-jr.49 [WebServer] Since '/' is treated as default entry point, expecting an error is wrong here. =============== Diff against WebClient-Tests-jr.49 =============== Item was changed: ----- Method: WebClientServerTest>>testListenOnInterface (in category 'tests - misc') ----- testListenOnInterface "Test that listening on a particular interface listens only on that interface" | localHostAddr resp localHostName client | server destroy. "kill old server" localHostAddr := NetNameResolver localHostAddress. localHostAddr asByteArray = #(127 0 0 1) asByteArray ifTrue:[^self]. "skip test" localHostName := NetNameResolver stringFromAddress: localHostAddr. server := WebServer new listenOn: self port interface: localHostAddr. server addService: '/' action:[:req| req send200Response: 'ok']. client := WebClient new. client timeout: 1. - self should:[resp := client httpGet: self localHostUrl, '/test'] raise: Error. resp := client httpGet: 'http://', localHostName, ':', self port asString, '/test'. self assert: resp code = 200. self assert: resp content = 'ok'. !

1 0

The Trunk: MorphicTests-mt.41.mcz
by commits＠source.squeak.org 01 Jul '17

01 Jul '17

Marcel Taeumel uploaded a new version of MorphicTests to project The Trunk: http://source.squeak.org/trunk/MorphicTests-mt.41.mcz ==================== Summary ==================== Name: MorphicTests-mt.41 Author: mt Time: 1 July 2017, 2:57:41.428352 pm UUID: ee05a5f6-3c62-1c46-af81-607c453de86c Ancestors: MorphicTests-nice.40 Adds a test for event handler and red/blue/yellow mouse down. =============== Diff against MorphicTests-nice.40 =============== Item was added: + ----- Method: MorphicEventTests>>test03EventHandler (in category 'tests') ----- + test03EventHandler + + | m | + m := Morph new. + m extent: 20@20; topLeft: 0@0. + + m wantsHaloFromClick: false. + m wantsYellowButtonMenu: false. + m wantsMetaMenu: false. + + m on: #mouseDown send: #value: to:[:evt| + evt redButtonPressed ifTrue:[m color: Color red]. + evt yellowButtonPressed ifTrue:[m color: Color yellow]. + evt blueButtonPressed ifTrue:[m color: Color blue]]. + + m openInWorld: world. + + hand handleEvent: (self redMouseDownAt: m center). + self assert: Color red equals: m color. + + hand handleEvent: (self yellowMouseDownAt: m center). + self assert: Color yellow equals: m color. + + hand handleEvent: (self blueMouseDownAt: m center). + self assert: Color blue equals: m color.! Item was added: + ----- Method: UserInputEventTests>>blueMouseDownAt: (in category 'support') ----- + blueMouseDownAt: point + + ^ MouseButtonEvent new + setType: #mouseDown + position: point + which: 2r000 "no change" + buttons: 2r001 "blue pressed" + hand: hand + stamp: Time millisecondClockValue! Item was added: + ----- Method: UserInputEventTests>>yellowMouseDownAt: (in category 'support') ----- + yellowMouseDownAt: point + + ^ MouseButtonEvent new + setType: #mouseDown + position: point + which: 2r000 "no change" + buttons: 2r010 "yellow pressed" + hand: hand + stamp: Time millisecondClockValue!

1 0

The Trunk: Graphics-mt.381.mcz
by commits＠source.squeak.org 01 Jul '17

01 Jul '17

Marcel Taeumel uploaded a new version of Graphics to project The Trunk: http://source.squeak.org/trunk/Graphics-mt.381.mcz ==================== Summary ==================== Name: Graphics-mt.381 Author: mt Time: 1 July 2017, 2:54:56.165352 pm UUID: e6886e0c-9704-2045-9724-eb6fd1d269ca Ancestors: Graphics-eem.380 Quick fix for preferring default/old color names over the crayon ones. We may want to rethink the lookup procedure in Color >> #name. =============== Diff against Graphics-eem.380 =============== Item was changed: ----- Method: Color class>>colorNames (in category 'other') ----- colorNames "Return a collection of color names." + ^ ColorNames asArray, self orderedCrayonColorNames! - ^ ColorNames, self orderedCrayonColorNames!

1 0