Packages December 2017

packages@lists.squeakfoundation.org

1 participants
92 discussions

The Trunk: ToolBuilder-Morphic-jr.202.mcz
by commits＠source.squeak.org 18 Dec '17

18 Dec '17

Marcel Taeumel uploaded a new version of ToolBuilder-Morphic to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Morphic-jr.202.mcz ==================== Summary ==================== Name: ToolBuilder-Morphic-jr.202 Author: jr Time: 10 December 2017, 5:21:48.408893 pm UUID: 4731ca9c-b924-514d-8f13-19a9913addb5 Ancestors: ToolBuilder-Morphic-tpr.201 fix choice from an empty list Before the preceding changes in 2016, the MorphicUIManager would answer 0 when the list to choose from was empty. After the changes, it would signal an error here: dialog selectedButtonIndex: 1. So guard against an empty list and answer 0 immediately. The case can be triggered in a fresh trunk image when you try to add a repository to an existing package without first adding an additional repository via the '+ Repository' button. There will be zero repositories to choose from. =============== Diff against ToolBuilder-Morphic-tpr.201 =============== Item was changed: ----- Method: MorphicUIManager>>chooseFrom:lines:title: (in category 'ui requests') ----- chooseFrom: aList lines: linesArray title: aString "Choose an item from the given list. Answer the index of the selected item." + aList ifEmpty: [^ 0]. aList size <= 7 ifTrue: [ | dialog | dialog := DialogWindow new title: 'Please Choose'; message: aString; filterEnabled: true; autoCancel: true; yourself. aList doWithIndex: [:ea :index | dialog createButton: ea value: index]. dialog selectedButtonIndex: 1. ^ dialog getUserResponseAtHand ifNil: [0]]. ^ ListChooser chooseFrom: aList title: aString!

1 0

The Trunk: System-dtl.989.mcz
by commits＠source.squeak.org 17 Dec '17

17 Dec '17

David T. Lewis uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-dtl.989.mcz ==================== Summary ==================== Name: System-dtl.989 Author: dtl Time: 17 December 2017, 10:56:50.75998 am UUID: 3a87ca02-6189-4f1e-b9f0-0853f9452351 Ancestors: System-dtl.985, System-eem.988 Emergency evaluator project enhancements. Project class>>handlePrimitiveError: will first try to find a parent project of different type (e.g. MVC if current project is Morphic, or vice versa) in which to host an emergency debugger. If no suitable parent project is found, search all projects to find any other project of different type. If no such project is found, then the traditional emergency evaluator transcript is opened. A guard flag prevents recursion when entering projects for emergency evaluation. For example, if a failure occurs in a Morphic project, and an MVC project has been entered for emergency evaluation, then subsequent error handling (if needed) will drop into the traditional emergency evaluator. When entering a project for emergency evaluation, let the resulting debugger display the name of the project from which the failure originated. A typical scenario is the case of an image with many Morphic projects, and one MVC project anywhere in the project hierarchy. In the event of an unrecoverable error in any of the Morphic projects, the MVC project will be identified as the project for emergency recovery. This permits an MVC debugger to be used to recover from the error condition, after which the failed Morphic user interface can be reentered. Other kinds of projects can also participate. If the parent project of a Morphic project is a SqueakShellProject, then a fatal error in the Morphic project will be handled by the SqueakShellProject. See the treated inbox for System-dtl.981 through System-dtl.985. =============== Diff against System-eem.988 =============== Item was changed: Model subclass: #Project instanceVariableNames: 'world uiManager changeSet transcript parentProject previousProject displayDepth viewSize thumbnail nextProject projectParameters version urlList lastDirectory lastSavedAtSeconds projectPreferenceFlagDictionary resourceManager' + classVariableNames: 'AllProjects CurrentProject EmergencyRecoveryRequested GoalFreePercent GoalNotMoreThan' - classVariableNames: 'AllProjects CurrentProject GoalFreePercent GoalNotMoreThan' poolDictionaries: '' category: 'System-Support'! !Project commentStamp: 'cbr 7/27/2010 21:36' prior: 0! A Project stores the state of a complete Squeak desktop, including the windows, and the currently active changeSet. A project knows who its parent project is. When you change projects, whether by entering or exiting, the screen state of the project being exited is saved in that project. A project is retained by its view in the parent world. It is effectively named by the name of its changeSet, which can be changed either by renaming in a changeSorter, or by editing the label of its view from the parent project. As the site of major context switch, Projects are the locus of swapping between the old MVC and the new Morphic worlds. The distinction is based on whether the variable 'world' contains a WorldMorph or a ControlManager. Saving and Loading Projects may be stored on the disk in external format. (Project named: 'xxx') exportSegment, or choose 'store project on file...'. Projects may be loaded from a server and stored back. Storing on a server never overwrites; it always makes a new version. A project remembers the url of where it lives in urlList. The list is length one, for now. The url may point to a local disk instead of a server. All projects that the user looks at are cached in the Squeaklet folder. Sorted by server. The cache holds the most recent version only. When a project is loaded into Squeak, its objects are converted to the current version. There are three levels of conversion. First, each object is converted from raw bits to an object in its old format. Then it is sent some or all of these messages: comeFullyUpOnReload: smartRefStream Used to re-discover an object that already exists in this image, such as a resource, global variable, Character, or Symbol. (sent to objects in outPointers) convertToCurrentVersion: varDict refStream: smartRefStrm fill in fields that have been added to a class since the object was stored. Used to set the extra inst var to a default value. Or, return a new object of a different class. (sent to objects that changed instance variables) fixUponLoad: aProject refStream: smartRefStrm change the object due to conventions that have changed on the project level. (sent to all objects in the incoming project) Here is the calling sequence for storing out a Project: Project saveAs Project storeOnServer Project storeOnServerWithProgressInfo Project storeOnServerInnards Project exportSegmentFileName:directory: Project exportSegmentWithChangeSet:fileName:directory: ImageSegment writeForExportWithSources:inDirectory:changeSet: ! Item was changed: ----- Method: Project class>>tryOtherProjectForRecovery: (in category 'error recovery') ----- tryOtherProjectForRecovery: errorMessage "Try entering the parent project if it uses a different user interface. We determine this by comparing the project's class." | safeProject nextProject | nextProject := Project current. safeProject := nil. + "Search parent projects for one of a different type" [safeProject notNil or: [nextProject isTopProject]] whileFalse: [ nextProject := nextProject parent. (Project current isKindOf: nextProject class) ifFalse: [safeProject := nextProject]]. + "No suitable parent project found, search all projects for any one of different type." + safeProject ifNil: [Smalltalk garbageCollect. + safeProject := Project allSubInstances + detect: [:proj | (proj isKindOf: Project current class) not] ifNone: []]. safeProject ifNotNil: [:p | p enterForEmergencyRecovery. + "Active process will usually suspend after this."]. + ! - "Active process will usually suspend after this."].! Item was changed: ----- Method: Project>>enter:revert:saveForRevert: (in category 'enter') ----- enter: returningFlag revert: revertFlag saveForRevert: saveForRevert "Install my ChangeSet, Transcript, and scheduled views as current globals. If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case. If saveForRevert is true, save the ImageSegment of the project being left. If revertFlag is true, make stubs for the world of the project being left. If revertWithoutAsking is true in the project being left, then always revert." | leavingProject forceRevert response seg | self isIncompletelyLoaded ifTrue: [^ self loadFromServer: true]. self isCurrentProject ifTrue: [^ self]. + EmergencyRecoveryRequested := false. "normal project entry clears recursion guard" forceRevert := false. CurrentProject rawParameters ifNil: [revertFlag ifTrue: [^ self inform: 'nothing to revert to' translated]] ifNotNil: [saveForRevert ifFalse: [ forceRevert := CurrentProject projectParameters at: #revertWithoutAsking ifAbsent: [false]]]. forceRevert not & revertFlag ifTrue: [ response := (UIManager default chooseFrom: { 'Revert to saved version' translated. 'Cancel' translated. } title: 'Are you sure you want to destroy this Project\ and revert to an older version?\\(From the parent project, click on this project''s thumbnail.)' translated withCRs) = 1. response ifFalse: [^ self]]. revertFlag | forceRevert ifTrue: [seg := CurrentProject projectParameters at: #revertToMe ifAbsent: [ ^ self inform: 'nothing to revert to' translated]] ifFalse: [ CurrentProject makeThumbnail. returningFlag == #specialReturn ifTrue: [ProjectHistory forget: CurrentProject. "this guy is irrelevant" Project forget: CurrentProject] ifFalse: [ProjectHistory remember: CurrentProject]]. (revertFlag | saveForRevert | forceRevert) ifFalse: [ (Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [ self inform: 'Project serialization via image segments\does not work at the moment. Disabling the\preference #projectsSentToDisk now...' withCRs. Preferences disable: #projectsSentToDisk. "self storeToMakeRoom"]]. "Update display depth for leaving and entring project." CurrentProject displayDepth: Display depth. displayDepth == nil ifTrue: [displayDepth := Display depth]. self installNewDisplay: Display extent depth: displayDepth. returningFlag == #specialReturn ifTrue: [ CurrentProject removeChangeSetIfPossible. "keep this stuff from accumulating" nextProject := nil ] ifFalse: [ returningFlag ifTrue: [nextProject := CurrentProject] ifFalse: [previousProject := CurrentProject]. ]. CurrentProject world triggerEvent: #aboutToLeaveWorld. CurrentProject abortResourceLoading. CurrentProject finalExitActions: self. CurrentProject saveState. "********** SWITCHING CURRENT PROJECT **********" leavingProject := CurrentProject. CurrentProject := self. ProjectHistory remember: self. "********** SWITCHING CURRENT PROJECT **********" self loadState. self finalEnterActions: leavingProject. self addDeferredUIMessage: [self startResourceLoading]. self world triggerEvent: #aboutToEnterWorld. "Save project for revert." saveForRevert ifTrue: [ Smalltalk garbageCollect. "let go of pointers" leavingProject storeSegment. "result :=" leavingProject world isInMemory ifTrue: ['Can''t seem to write the project.'] ifFalse: [leavingProject projectParameters at: #revertToMe put: leavingProject world xxxSegment shallowCopy]. 'Project written.']. "original is for coming back in and continuing." revertFlag | forceRevert ifTrue: [ seg shallowCopy revert]. "non-cloned one is for reverting again later" self removeParameter: #exportState. "Now that everything is set up, we can show zoom animation." self showZoom ifTrue: [self displayZoom: leavingProject parent ~~ self "Entering?"] ifFalse: [self restore]. "Update processes at last." self scheduleProcessForEnter. leavingProject terminateProcessForLeave. ! Item was changed: ----- Method: Project>>enterForEmergencyRecovery (in category 'enter - recovery') ----- enterForEmergencyRecovery "Stripped down verion of #enter:revert:saveForRevert:. More error handling. Less features." + | leavingProject process titleForDebuggerWindow | - | leavingProject process | self isCurrentProject ifTrue: [^ self]. + EmergencyRecoveryRequested == true ifTrue: [^ self]. + EmergencyRecoveryRequested := true. "set recursion guard" + + titleForDebuggerWindow := 'FATAL PROJECT ERROR: Project was ''', CurrentProject name, ''''. - ProjectHistory remember: CurrentProject. nextProject := CurrentProject. [ CurrentProject world triggerEvent: #aboutToLeaveWorld. CurrentProject abortResourceLoading. CurrentProject finalExitActions: self. CurrentProject saveState ] on: Error do: [:ex | "Ignore." ]. "********** SWITCHING CURRENT PROJECT **********" leavingProject := CurrentProject. CurrentProject := self. ProjectHistory remember: self. "********** SWITCHING CURRENT PROJECT **********" self loadState. self finalEnterActions: leavingProject. self addDeferredUIMessage: [self startResourceLoading]. self world triggerEvent: #aboutToEnterWorld. "Now that everything is set up, we can show zoom animation. Do we really need this in case of an emergency?" self showZoom ifTrue: [self displayZoom: leavingProject parent ~~ self "Entering?"] ifFalse: [self restore]. "Update processes at last." self scheduleProcessForEnter. "Do not terminate but suspend the projects ui process to support debugging." process := leavingProject uiProcess. + self addDeferredUIMessage: [process debugWithTitle: titleForDebuggerWindow]. - self addDeferredUIMessage: [process debugWithTitle: 'FATAL PROJECT ERROR!!']. leavingProject suspendProcessForDebug.!

1 0

The Trunk: System-eem.988.mcz
by commits＠source.squeak.org 16 Dec '17

16 Dec '17

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-eem.988.mcz ==================== Summary ==================== Name: System-eem.988 Author: eem Time: 15 December 2017, 3:09:47.548729 pm UUID: d167e6c2-1ca3-4f91-b856-189fa213889c Ancestors: System-eem.987 Spur Image Segment Loading across word sizes. Reduce LargePositiveIntegers and BoxedFloat64 to SmallInteger and SmallFloat64 immediates when in range and loading 32-bit segments into 64-bit systems. Fix the word order of BoxedFloat64 which are typically in little-endian order internally but big-endian order externally. =============== Diff against System-eem.987 =============== Item was changed: SpurImageSegmentLoader subclass: #Spur32BitImageSegmentLoader + instanceVariableNames: 'rangeMappings' - instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Object Storage'! Item was changed: ----- Method: Spur32BitImageSegmentLoader>>allocateObject:classIndex:slots: (in category 'reading') ----- allocateObject: format classIndex: classIndex slots: numSlots "Allocate an instance of the class referenced by classIndex, with the size computed from numSlots and format." + | class obj | - | class | class := (self classIndexInOutPointers: classIndex) ifTrue: [outPointers at: (self outPointerIndexForClassIndex: classIndex)] ifFalse: [oopMap at: (self oopIndexForClassIndex: classIndex)]. (format <= 1 or: [format = 5"ephemerons"]) ifTrue: [^self allocateFixedSizeObject: class size: numSlots]. format = 2 ifTrue: [^self allocateVariableSizeObject: class size: numSlots]. (format between: 3 and: 4) ifTrue: [^self allocateFixedAndVariableObject: class size: numSlots]. format >= 16 ifTrue: [| nBytes | nBytes := numSlots * 4 - (format bitAnd: 3). format >= 24 ifTrue: [^self allocateCompiledCode: class size: nBytes]. + obj := self allocate8BitObject: class size: nBytes. + (nBytes <= 8 and: [obj isInteger and: [rangeMappings notNil]]) ifTrue: + [rangeMappings addLast: obj]. + ^obj]. - ^self allocate8BitObject: class size: nBytes]. format >= 12 ifTrue: [| nShorts | nShorts := numSlots * 2 - (format bitAnd: 1). ^self allocate16BitObject: class size: nShorts]. format >= 10 ifTrue: + [obj := self allocate32BitObject: class size: numSlots. + (numSlots = 2 and: [obj isFloat and: [rangeMappings notNil]]) ifTrue: + [rangeMappings addLast: obj]. + ^obj]. - [^self allocate32BitObject: class size: numSlots]. format = 9 ifTrue: [^self allocate64BitObject: class size: numSlots * 2]. format = 33 ifTrue: [^self allocateAndPartFillClassObject: class size: numSlots]. self error: 'Unknown object format'! Item was added: + ----- Method: Spur32BitImageSegmentLoader>>loadSegmentFrom:outPointers: (in category 'loading') ----- + loadSegmentFrom: segmentWordArray outPointers: outPointerArray + "Override to initialize rangeMappings if loading a 32-bit segment into a 64-bit system" + + | result | + Smalltalk wordSize = 8 ifTrue: + [rangeMappings := OrderedCollection new]. + result := super loadSegmentFrom: segmentWordArray outPointers: outPointerArray. + self maybeMapRanges. + ^result! Item was added: + ----- Method: Spur32BitImageSegmentLoader>>maybeMapRanges (in category 'private') ----- + maybeMapRanges + "If loading a 32-bit segment into a 64-bit segment then map LargePositiveIntegers or BoxedFloat64 + instances that can be expressed as SmallInteger or SmallFloat64 immediates respectively. + Implement as a bulk become for speed." + + | ins outs | + rangeMappings ifNil: [^self]. + ins := WriteStream on: (Array new: rangeMappings size). + outs := WriteStream on: (Array new: rangeMappings size). + rangeMappings do: + [:numeric| | mapping | + (numeric isInteger + ifTrue: + [mapping := numeric normalize. + mapping ~~ numeric] + ifFalse: + [mapping := numeric * 1.0. + mapping class ~~ numeric class]) ifTrue: + [ins nextPut: numeric. + outs nextPut: mapping]]. + ins position > 0 ifTrue: + [ins contents elementsForwardIdentityTo: outs contents copyHash: false]! Item was changed: ----- Method: SpurImageSegmentLoader>>fillWords:oop: (in category 'reading') ----- fillWords: object oop: oop + | size | + size := object basicSize. + (size = 2 and: [object isFloat]) + ifTrue: "boxed floats are in platform order internally (hence in platform order in the segment) but in big-endian order externally" + [object + basicAt: 2 put: self readUint32; + basicAt: 1 put: self readUint32] + ifFalse: + [1 to: object basicSize do: + [:i | + object basicAt: i put: self readUint32]]. - 1 to: object basicSize do: - [:i | - object basicAt: i put: self readUint32]. ^object!

1 0

The Trunk: System-eem.987.mcz
by commits＠source.squeak.org 15 Dec '17

15 Dec '17

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-eem.987.mcz ==================== Summary ==================== Name: System-eem.987 Author: eem Time: 15 December 2017, 2:19:51.532605 pm UUID: 5f61563a-54e7-4ec7-a2dc-8bd71ce75760 Ancestors: System-eem.986 Spur Image Segments. Fix mapping of out pointer oops in 32-bit segment loads. Fix typos & tweak comments. Nuke an inadvertent halt. =============== Diff against System-eem.986 =============== Item was changed: ----- Method: Spur32BitImageSegmentLoader>>mapPC:in: (in category 'private') ----- mapPC: pc in: compiledCode + "Assuming the word size of compiledCode is 8, and that the pc is one for a word size of 4, + map the pc from 4 to 8 byte literals. The filter is in updatePCDependentObjects." - "Assuming the word size of compiledCode is 8, and that the pc is one for a word size of 4, map the pc from 4 to 8. - The filter is in updatePCDependentObjects." ^pc + (compiledCode numLiterals + 1 * 4)! Item was changed: ----- Method: Spur32BitImageSegmentLoader>>readOop (in category 'reading') ----- readOop "Read an oop and map it to an object: - The oop may be immediate in which case its tag indicates its class and the remeaining bits its value. - the oop may have its top bit set in which case it is an index into the outPointers - otherwise the oop is a byte offset from the start of the first object in the segment and is in oopMap" | oop topBit | oop := self readUint32. topBit := oop bitShift: -31. ^(oop bitAnd: 3) caseOf: { [0] -> [topBit = 1 + ifTrue: [outPointers at: oop - 16r80000000 / 4 + 1] - ifTrue: [outPointers at: oop - 16r80000000 / 8 + 1] ifFalse: [oopMap at: oop]]. [1] -> [(oop bitShift: -1) - (topBit = 1 ifTrue: [16r80000000] ifFalse: [0])]. [3] -> [(oop bitShift: -1) - (topBit = 1 ifTrue: [16r80000000] ifFalse: [0])]. [2] -> [Character value: (oop bitShift: -2)]}! Item was changed: ----- Method: Spur64BitImageSegmentLoader>>mapPC:in: (in category 'private') ----- mapPC: pc in: compiledCode + "Assuming the word size of compiledCode is 4, and that the pc is one for a word size of 8, + map the pc from 8 to 4 byte literals. The filter is in updatePCDependentObjects." - "Assuming the word size of compiledCode is 4, and that the pc is one for a word size of 8, map the pc from 8 to 4. - The filter is in updatePCDependentObjects." ^pc - (compiledCode numLiterals + 1 * 4)! Item was changed: ----- Method: Spur64BitImageSegmentLoader>>readObject (in category 'reading') ----- readObject "Read the header and the class of the object, instantiate it, and store it in oopMap at its oop." | headerLo headerHi oop numSlots classIndex format rawNumSlots | "the oop is the address of the two byte header (which follows the overflow size word, if there is one)." oop := position - 8. "compensate for 64-bit version stamp" - oop = 1390072 ifTrue: [self halt]. headerLo := self readUint32. headerHi := self readUint32. rawNumSlots := headerHi bitShift: -24. rawNumSlots = 255 ifTrue: "128-bit header; overflow slots in least significant 32 bits of first 64-bit header word" [numSlots := headerLo. oop := position - 8. "compensate for 64-bit version stamp" headerLo := self readUint32. headerHi := self readUint32] ifFalse: "64-bit header" [numSlots := rawNumSlots]. "N.B. The format field is a 5 bit field, but immediately above it is the remembered bit which is used to mark classes is the segment." self checkValidFormat: (format := (headerLo bitShift: -24) bitAnd: 63). classIndex := headerLo bitAnd: 16r3FFFFF. ^[oopMap at: oop ifAbsentPut: [self allocateObject: format classIndex: classIndex slots: numSlots]] ensure: "Spur objects have at least one slot" [position := oop + 16 + ((numSlots max: 1) * 8)]! Item was changed: ----- Method: Spur64BitImageSegmentLoader>>readOop (in category 'reading') ----- readOop "Read an oop and map it to an object: - The oop may be immediate in which case its tag indicates its class and the remeaining bits its value. - the oop may have its top bit set in which case it is an index into the outPointers - otherwise the oop is a byte offset from the start of the first object in the segment and is in oopMap. The method is written to avoid large integer arithmetic as much as possible." | lo hi topBit oop | lo := self readUint32. hi := self readUint32. topBit := hi bitShift: -31. ^(lo bitAnd: 7) caseOf: { [0] -> [topBit = 1 ifTrue: [oop := (hi - 16r80000000 bitShift: 32) + lo. outPointers at: oop / 8 + 1] ifFalse: [oop := (hi bitShift: 32) + lo. oopMap at: oop]]. [1] -> [(lo bitShift: -3) bitOr: (hi - (topBit = 1 ifTrue: [16r100000000] ifFalse: [0]) bitShift: 29)]. [2] -> [Character value: ((lo bitShift: -3) bitOr: (hi bitShift: 29))]. [4] -> [(hi = 0 and: [lo <= 15]) "+ve & -ve zero" ifTrue: [lo <= 7 ifTrue: [0.0] ifFalse: [-0.0]] ifFalse: "convert lo: | tag | sign | mantissa low 28 bits | hi: | mantissa high 24 bits | exponent - 896 | to hi: | mantissa high 20 bits | exponent 11 bits | sign | lo: | mantissa low 32 bits |" + [(BoxedFloat64 basicNew: 2) - [^(BoxedFloat64 basicNew: 2) basicAt: 1 put: ((lo bitAnd: 8) bitShift: 28) + ((hi bitShift: -4) + (896 bitShift: 20)); basicAt: 2 put: (lo bitShift: -4) + ((hi bitAnd: 15) bitShift: 28); + * 1.0 "& reduce to SmallFloat64 if possible"]]} - * 1.0]]} otherwise: [self error: 'unrecognized tag pattern']! Item was changed: ----- Method: SpurImageSegmentLoader>>oopIndexForClassIndex: (in category 'private') ----- oopIndexForClassIndex: classIndex + "When a classIndex doesn't have the topBit set it maps to an oop in the segment thusly:" - "Whebn a classIndex doesn't have the topBit set it maps to an oop in the segment thusly:" ^classIndex - 16 "self firstClassIndexPun" * 8 "self allocationUnit"!

1 0

The Trunk: System-eem.986.mcz
by commits＠source.squeak.org 15 Dec '17

15 Dec '17

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-eem.986.mcz ==================== Summary ==================== Name: System-eem.986 Author: eem Time: 15 December 2017, 1:20:51.087309 pm UUID: c2b6f9bb-8a44-41c6-ada3-41bdff1b0676 Ancestors: System-eem.985 Doh! PCs in contexts and blocks must also be mapped when moving between word sizes. This fixes loading 64-bit projects into 32-bits. Still seem to be issues going the other way. Also eliminate an activation by inlining uint32At: into readUint32. =============== Diff against System-eem.985 =============== Item was added: + ----- Method: Spur32BitImageSegmentLoader>>mapPC:in: (in category 'private') ----- + mapPC: pc in: compiledCode + "Assuming the word size of compiledCode is 8, and that the pc is one for a word size of 4, map the pc from 4 to 8. + The filter is in updatePCDependentObjects." + ^pc + (compiledCode numLiterals + 1 * 4)! Item was added: + ----- Method: Spur32BitImageSegmentLoader>>updatePCDependentObjects (in category 'reading') ----- + updatePCDependentObjects + Smalltalk wordSize ~= 4 ifTrue: + [super updatePCDependentObjects]! Item was added: + ----- Method: Spur64BitImageSegmentLoader>>mapPC:in: (in category 'private') ----- + mapPC: pc in: compiledCode + "Assuming the word size of compiledCode is 4, and that the pc is one for a word size of 8, map the pc from 8 to 4. + The filter is in updatePCDependentObjects." + ^pc - (compiledCode numLiterals + 1 * 4)! Item was added: + ----- Method: Spur64BitImageSegmentLoader>>updatePCDependentObjects (in category 'filling') ----- + updatePCDependentObjects + Smalltalk wordSize ~= 8 ifTrue: + [super updatePCDependentObjects]! Item was changed: Object subclass: #SpurImageSegmentLoader + instanceVariableNames: 'segment outPointers oopMap position pcDependentObjects' - instanceVariableNames: 'segment outPointers oopMap position' classVariableNames: 'TopHashBit' poolDictionaries: '' category: 'System-Object Storage'! !SpurImageSegmentLoader commentStamp: 'eem 12/15/2017 11:20' prior: 0! SpurImageSegmentLoader is the abstract class for loaders of 32-bit and 64-bit Spur image segments. The VM has both storing and loading primitives and the store primitive is always used. The load primitive is used when the word size of the current system matches that of the stored segment (orf the word size of the system in which the segment was stored). A word on encoding. The keys in oopMap are byte positions of the start of the object, offset by the 64-bit version stamp. So the first object, which has oop 0, is in the map at 0, and corresponds to index 3 in the segment data. position starts at zero and readUInt32 increments position by 4 before using uint32At: to access segment. Hence the first access via readUInt32 is of index 1 in segment data. Later on position is reset to 8 bytes beyond the oop to access the data. Instance Variables oopMap: <Dictionary of: oop (Integer) -> object> outPointers: <Array> position: <Integer> segment: <WordArrayForSegment> oopMap - the map from the oop of an object to the object with that oop outPointers - the array of imported objects, objects not in the segment but referred to by the segment position - the current position when parsing the segment segment - the segment data, which starts with 64-bits of version stamp, so the first object starts at index 3, and has oop 0. ! Item was changed: ----- Method: SpurImageSegmentLoader>>fillObject:oop: (in category 'filling') ----- fillObject: object oop: oop + "Fill the object's inst vars with data/other objects. Remember any pc-dependent objects (contexts + and blocks) so that their pcs can be updated when their methods have been brought in as well." - "Fill the object's inst vars with data/other objects." | class | "First set position to 4 bytes before the first field, in readiness to read the object's data" position := oop + 16. "8 bytes of version stamp + 8 bytes of object header - 4 bytes of preincrement + 4 bytes 0->1 relative index" class := object class. class isPointers ifTrue: [class isVariable ifTrue: [object isContext ifTrue: + [pcDependentObjects addLast: object. + ^self fillContext: object oop: oop]. + object isBlock ifTrue: + [pcDependentObjects addLast: object]. - [^self fillContext: object oop: oop]. ^self fillVariablePointers: object oop: oop]. object isBehavior ifTrue: [^self fillBehavior: object oop: oop]. ^self fillPointers: object oop: oop]. class isBytes ifTrue: [object isCompiledCode ifTrue: [^self fillCompiledCode: object oop: oop]. ^self fillBytes: object oop: oop]. class isWords ifTrue: [^self fillWords: object oop: oop]. class isLongs ifTrue: [^self fillWords: object oop: oop]. ^self fillShorts: object oop: oop! Item was changed: ----- Method: SpurImageSegmentLoader>>loadSegmentFrom:outPointers: (in category 'loading') ----- loadSegmentFrom: segmentWordArray outPointers: outPointerArray | version end memory | segment := segmentWordArray. outPointers := outPointerArray. position := 0. version := self readUint32. (self validImageSegmentVersion: (version bitAnd: 16rFFFFFF)) ifFalse: [^self error: 'Cannot read this segment (endianness?)']. "First allocate all objects, then fill in their fields via oopMap" memory := OrderedCollection new: 1000. oopMap := Dictionary new. + pcDependentObjects := OrderedCollection new. end := segment size * 4. position := 8. [position < end] whileTrue: [memory addLast: self readObject]. self ignoringAccessToWordAfterSegmentDo: [oopMap keysAndValuesDo: [:oop :obj | self fillObject: obj oop: oop]]. + self updatePCDependentObjects. "Answer list of all objects (unlike primitive, which returned the first object and relied on other objects being consecutive in memory)" ^memory! Item was changed: ----- Method: SpurImageSegmentLoader>>readUint32 (in category 'reading') ----- readUint32 + ^segment at: (position := position + 4) // 4! - ^self uint32At: (position := position + 4)! Item was removed: - ----- Method: SpurImageSegmentLoader>>uint32At: (in category 'reading') ----- - uint32At: addr - "TODO: do endian conversion here" - "also read the class comment" - ^segment at: addr // 4! Item was added: + ----- Method: SpurImageSegmentLoader>>updatePCDependentObjects (in category 'filling') ----- + updatePCDependentObjects + pcDependentObjects do: + [:contextOrBlock| + + contextOrBlock isContext ifTrue: + [contextOrBlock pc ifNotNil: + [:pc| contextOrBlock pc: (self mapPC: pc in: contextOrBlock method)]]. + + (contextOrBlock isBlock + and: [contextOrBlock isFullBlock not])ifTrue: + [contextOrBlock instVarNamed: 'startpc' put: (self mapPC: contextOrBlock startpc in: contextOrBlock method)]]!

1 0

The Trunk: Kernel-eem.1131.mcz
by commits＠source.squeak.org 15 Dec '17

15 Dec '17

Eliot Miranda uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-eem.1131.mcz ==================== Summary ==================== Name: Kernel-eem.1131 Author: eem Time: 15 December 2017, 12:54:29.762591 pm UUID: abc9b3f5-c437-49fd-ac81-a04779514f5b Ancestors: Kernel-eem.1130 PC mapping on loading different word size segments needs to differentiate between BlockClosure and FullBlockClosure. Fix some typos in Float>>basicAt:[put:] =============== Diff against Kernel-eem.1130 =============== Item was added: + ----- Method: BlockClosure>>isFullBlock (in category 'testing') ----- + isFullBlock + ^false! Item was changed: ----- Method: Float>>basicAt: (in category 'accessing') ----- basicAt: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive. This version of basicAt: is specifically for floats, answering the most significant + word for index 1 and the least significant word for index 2. This allows the VM - word for index 1 and the least significant word for index 2. This alows the VM to store floats in whatever order it chooses while it appears to the image that they are always in big-endian/PowerPC order." <primitive: 38 error: ec> + ec ifNil: "primitive not implemented; floats are in big-endian/PowerPC order." - ec == nil ifTrue: "primitive not implemented; floats are in big-endian/PowerPC order." [^super basicAt: index]. index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self basicAt: index asInteger] ifFalse: [self errorNonIntegerIndex]! Item was changed: ----- Method: Float>>basicAt:put: (in category 'accessing') ----- basicAt: index put: value "Primitive. Assumes receiver is indexable. Store the second argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive. This version of basicAt: is specifically for floats, answering the most significant + word for index 1 and the least significant word for index 2. This allows the VM - word for index 1 and the least significant word for index 2. This alows the VM to store floats in whatever order it chooses while it appears to the image that they are always in big-endian/PowerPC order." <primitive: 39 error: ec> + ec ifNil: "primitive not implemented; floats are in big-endian/PowerPC order." - ec == nil ifTrue: "primitive not implemented; floats are in big-endian/PowerPC order." [^super basicAt: index put: value]. index isInteger ifTrue: [(index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]]. index isNumber ifTrue: [^self basicAt: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! Item was added: + ----- Method: FullBlockClosure>>isFullBlock (in category 'testing') ----- + isFullBlock + ^true!

1 0

The Trunk: System-eem.985.mcz
by commits＠source.squeak.org 15 Dec '17

15 Dec '17

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-eem.985.mcz ==================== Summary ==================== Name: System-eem.985 Author: eem Time: 15 December 2017, 12:39:23.474652 pm UUID: ab9f2a41-0c2e-43b9-a6e5-666d9ffb9a10 Ancestors: System-eem.984 For loading 32-bit projects on 64-bits allocateObject:classIndex:slots: must be implemented in Spur32BitImageSegmentLoader and the delta for CompiledCode computed correctly. =============== Diff against System-eem.984 =============== Item was changed: ----- Method: Spur32BitImageSegmentLoader>>allocateCompiledCode:size: (in category 'reading') ----- allocateCompiledCode: class size: nBytes "Allocate a CompiledCode object. nBytes must be reduced by the number of objects in the method (header and literals)." | header delta | class isCompiledMethodClass ifFalse: [self error: 'compiled code class expected']. header := self readOop. + delta := (header bitAnd: 32767) + 1 * 4. - delta := (header bitAnd: 32767) + 1 * 8. ^class newMethod: nBytes - delta header: header! Item was added: + ----- Method: Spur32BitImageSegmentLoader>>allocateObject:classIndex:slots: (in category 'reading') ----- + allocateObject: format classIndex: classIndex slots: numSlots + "Allocate an instance of the class referenced by classIndex, with the size computed from numSlots and format." + | class | + class := (self classIndexInOutPointers: classIndex) + ifTrue: [outPointers at: (self outPointerIndexForClassIndex: classIndex)] + ifFalse: [oopMap at: (self oopIndexForClassIndex: classIndex)]. + (format <= 1 or: [format = 5"ephemerons"]) ifTrue: + [^self allocateFixedSizeObject: class size: numSlots]. + format = 2 ifTrue: + [^self allocateVariableSizeObject: class size: numSlots]. + (format between: 3 and: 4) ifTrue: + [^self allocateFixedAndVariableObject: class size: numSlots]. + format >= 16 ifTrue: + [| nBytes | + nBytes := numSlots * 4 - (format bitAnd: 3). + format >= 24 ifTrue: + [^self allocateCompiledCode: class size: nBytes]. + ^self allocate8BitObject: class size: nBytes]. + format >= 12 ifTrue: + [| nShorts | + nShorts := numSlots * 2 - (format bitAnd: 1). + ^self allocate16BitObject: class size: nShorts]. + format >= 10 ifTrue: + [^self allocate32BitObject: class size: numSlots]. + format = 9 ifTrue: + [^self allocate64BitObject: class size: numSlots * 2]. + format = 33 ifTrue: + [^self allocateAndPartFillClassObject: class size: numSlots]. + self error: 'Unknown object format'! Item was added: + ----- Method: Spur64BitImageSegmentLoader>>allocateObject:classIndex:slots: (in category 'reading') ----- + allocateObject: format classIndex: classIndex slots: numSlots + "Allocate an instance of the class referenced by classIndex, with the size computed from numSlots and format." + | class | + class := (self classIndexInOutPointers: classIndex) + ifTrue: [outPointers at: (self outPointerIndexForClassIndex: classIndex)] + ifFalse: [oopMap at: (self oopIndexForClassIndex: classIndex)]. + (format <= 1 or: [format = 5"ephemerons"]) ifTrue: + [^self allocateFixedSizeObject: class size: numSlots]. + format = 2 ifTrue: + [^self allocateVariableSizeObject: class size: numSlots]. + (format between: 3 and: 4) ifTrue: + [^self allocateFixedAndVariableObject: class size: numSlots]. + format >= 16 ifTrue: + [| nBytes | + nBytes := numSlots * 8 - (format bitAnd: 7). + format >= 24 ifTrue: + [^self allocateCompiledCode: class size: nBytes]. + ^self allocate8BitObject: class size: nBytes]. + format >= 12 ifTrue: + [| nShorts | + nShorts := numSlots * 4 - (format bitAnd: 3). + ^self allocate16BitObject: class size: nShorts]. + format >= 10 ifTrue: + [| nWords | + nWords := numSlots * 2 - (format bitAnd: 1). + ^self allocate32BitObject: class size: nWords]. + format = 9 ifTrue: + [^self allocate64BitObject: class size: numSlots]. + format = 33 ifTrue: + [^self allocateAndPartFillClassObject: class size: numSlots]. + self error: 'Unknown object format'! Item was changed: ----- Method: SpurImageSegmentLoader>>allocateObject:classIndex:slots: (in category 'reading') ----- allocateObject: format classIndex: classIndex slots: numSlots + "Allocate an instance of the class referenced by classIndex, with the size computed from numSlots and format." + self subclassResponsibility! - | class | - class := (self classIndexInOutPointers: classIndex) - ifTrue: [outPointers at: (self outPointerIndexForClassIndex: classIndex)] - ifFalse: [oopMap at: (self oopIndexForClassIndex: classIndex)]. - (format <= 1 or: [format = 5"ephemerons"]) ifTrue: - [^self allocateFixedSizeObject: class size: numSlots]. - format = 2 ifTrue: - [^self allocateVariableSizeObject: class size: numSlots]. - (format between: 3 and: 4) ifTrue: - [^self allocateFixedAndVariableObject: class size: numSlots]. - format >= 16 ifTrue: - [| nBytes | - nBytes := numSlots * 8 - (format bitAnd: 7). - format >= 24 ifTrue: - [^self allocateCompiledCode: class size: nBytes]. - ^self allocate8BitObject: class size: nBytes]. - format >= 12 ifTrue: - [| nShorts | - nShorts := numSlots * 4 - (format bitAnd: 3). - ^self allocate16BitObject: class size: nShorts]. - format >= 10 ifTrue: - [| nWords | - nWords := numSlots * 2 - (format bitAnd: 1). - ^self allocate32BitObject: class size: nWords]. - format = 9 ifTrue: - [^self allocate64BitObject: class size: numSlots]. - format = 33 ifTrue: - [^self allocateAndPartFillClassObject: class size: numSlots]. - self error: 'Unknown object format'!

1 0

The Trunk: System-eem.984.mcz
by commits＠source.squeak.org 15 Dec '17

15 Dec '17

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-eem.984.mcz ==================== Summary ==================== Name: System-eem.984 Author: eem Time: 15 December 2017, 12:20:37.361387 pm UUID: d83e303e-6de0-4579-8931-2fa6d97999b0 Ancestors: System-eem.983 Support for loading Spur projects between 32-bit and 64-bit versions, closely following Bert's legacy ImageSegmentLoader scheme. While one can load projects one gets an error due to method trailers. I'm not sure what the right thing to do is. I don't think it's the Spur image segment loader's job to nil trailer bytes in loaded compiled methods. So I'm comitting and will discuss with others as to where the right point to nil trailers on project loading is. =============== Diff against System-eem.983 =============== Item was changed: ----- Method: NativeImageSegment>>loadSegmentFrom:outPointers: (in category 'read/write segment primitives') ----- loadSegmentFrom: segmentWordArray outPointers: outPointerArray "Load segmentWordArray into the memory. Adapt the primitive to the new API, which is to answer the array of loaded objects, the first of which should be the array of roots. The primitive will install a binary image segment and return as its value the array of roots of the tree of objects represented. Upon successful completion, the + wordArray will have been becomed into anArray of the loaded objects. So simply answer the segmentWordArray which will have becommed." - wordArray will have been becomed into anArray of the loaded objects. So simply answer the segmentWordArray which will have becommed ." + | segmentFormat | + segmentFormat := segmentWordArray first bitAnd: 16rFFFFFF. + segmentFormat = Smalltalk imageFormatVersion ifTrue: + [^(self primitiveLoadSegmentFrom: segmentWordArray outPointers: outPointerArray) + ifNil: [self error: 'segment load failed'] + ifNotNil: [segmentWordArray]]. + segmentFormat >= 68000 + ifTrue: + [Smalltalk wordSize = 4 ifTrue: + [^(Spur64BitImageSegmentLoader new loadSegmentFrom: segmentWordArray outPointers: outPointerArray)]] + ifFalse: + [Smalltalk wordSize = 8 ifTrue: + [^(Spur32BitImageSegmentLoader new loadSegmentFrom: segmentWordArray outPointers: outPointerArray)]]. + self error: 'segment version unrecognized'! - ^(self primitiveLoadSegmentFrom: segmentWordArray outPointers: outPointerArray) - ifNil: [self error: 'segment load failed'] - ifNotNil: [segmentWordArray]! Item was added: + SpurImageSegmentLoader subclass: #Spur32BitImageSegmentLoader + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'System-Object Storage'! Item was added: + ----- Method: Spur32BitImageSegmentLoader>>allocateCompiledCode:size: (in category 'reading') ----- + allocateCompiledCode: class size: nBytes + "Allocate a CompiledCode object. nBytes must be reduced + by the number of objects in the method (header and literals)." + | header delta | + class isCompiledMethodClass ifFalse: + [self error: 'compiled code class expected']. + header := self readOop. + delta := (header bitAnd: 32767) + 1 * 8. + ^class newMethod: nBytes - delta header: header! Item was added: + ----- Method: Spur32BitImageSegmentLoader>>readObject (in category 'reading') ----- + readObject + "Read the header and the class of the object, instantiate it, and store it in oopMap at its oop." + | headerLo headerHi oop numSlots classIndex format rawNumSlots | + "the oop is the address of the two byte header (which follows the overflow size word, if there is one)." + oop := position - 8. "compensate for 64-bit version stamp" + headerLo := self readUint32. + headerHi := self readUint32. + rawNumSlots := headerHi bitShift: -24. + rawNumSlots = 255 + ifTrue: "128-bit header; overflow slots in least significant 32 bits of first 64-bit header word" + [numSlots := headerLo. + oop := position - 8. "compensate for 64-bit version stamp" + headerLo := self readUint32. + headerHi := self readUint32] + ifFalse: "64-bit header" + [numSlots := rawNumSlots]. + "N.B. The format field is a 5 bit field, but immediately above it is the + remembered bit which is used to mark classes is the segment." + self checkValidFormat: (format := (headerLo bitShift: -24) bitAnd: 63). + classIndex := headerLo bitAnd: 16r3FFFFF. + ^[oopMap at: oop ifAbsentPut: + [self allocateObject: format classIndex: classIndex slots: numSlots]] + ensure: "Spur objects have at least one slot and are rounded up to a multiple of 64-bits/8 bytes in length" + [position := oop + 16 + ((numSlots max: 1) + 1 // 2 * 8)]! Item was added: + ----- Method: Spur32BitImageSegmentLoader>>readOop (in category 'reading') ----- + readOop + "Read an oop and map it to an object: + - The oop may be immediate in which case its tag indicates its class and the remeaining bits its value. + - the oop may have its top bit set in which case it is an index into the outPointers + - otherwise the oop is a byte offset from the start of the first object in the segment and is in oopMap" + | oop topBit | + oop := self readUint32. + topBit := oop bitShift: -31. + ^(oop bitAnd: 3) caseOf: { + [0] -> [topBit = 1 + ifTrue: [outPointers at: oop - 16r80000000 / 8 + 1] + ifFalse: [oopMap at: oop]]. + [1] -> [(oop bitShift: -1) - (topBit = 1 ifTrue: [16r80000000] ifFalse: [0])]. + [3] -> [(oop bitShift: -1) - (topBit = 1 ifTrue: [16r80000000] ifFalse: [0])]. + [2] -> [Character value: (oop bitShift: -2)]}! Item was added: + ----- Method: Spur32BitImageSegmentLoader>>validImageSegmentVersion: (in category 'private') ----- + validImageSegmentVersion: threeByteInteger + ^threeByteInteger = 6521! Item was added: + SpurImageSegmentLoader subclass: #Spur64BitImageSegmentLoader + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'System-Object Storage'! Item was added: + ----- Method: Spur64BitImageSegmentLoader>>allocateCompiledCode:size: (in category 'reading') ----- + allocateCompiledCode: class size: nBytes + "Allocate a CompiledCode object. nBytes must be reduced + by the number of objects in the method (header and literals)." + | header delta | + class isCompiledMethodClass ifFalse: + [self error: 'compiled code class expected']. + header := self readOop. + delta := (header bitAnd: 32767) + 1 * 8. + ^class newMethod: nBytes - delta header: header! Item was added: + ----- Method: Spur64BitImageSegmentLoader>>readObject (in category 'reading') ----- + readObject + "Read the header and the class of the object, instantiate it, and store it in oopMap at its oop." + | headerLo headerHi oop numSlots classIndex format rawNumSlots | + "the oop is the address of the two byte header (which follows the overflow size word, if there is one)." + oop := position - 8. "compensate for 64-bit version stamp" + oop = 1390072 ifTrue: [self halt]. + headerLo := self readUint32. + headerHi := self readUint32. + rawNumSlots := headerHi bitShift: -24. + rawNumSlots = 255 + ifTrue: "128-bit header; overflow slots in least significant 32 bits of first 64-bit header word" + [numSlots := headerLo. + oop := position - 8. "compensate for 64-bit version stamp" + headerLo := self readUint32. + headerHi := self readUint32] + ifFalse: "64-bit header" + [numSlots := rawNumSlots]. + "N.B. The format field is a 5 bit field, but immediately above it is the + remembered bit which is used to mark classes is the segment." + self checkValidFormat: (format := (headerLo bitShift: -24) bitAnd: 63). + classIndex := headerLo bitAnd: 16r3FFFFF. + ^[oopMap at: oop ifAbsentPut: + [self allocateObject: format classIndex: classIndex slots: numSlots]] + ensure: "Spur objects have at least one slot" + [position := oop + 16 + ((numSlots max: 1) * 8)]! Item was added: + ----- Method: Spur64BitImageSegmentLoader>>readOop (in category 'reading') ----- + readOop + "Read an oop and map it to an object: + - The oop may be immediate in which case its tag indicates its class and the remeaining bits its value. + - the oop may have its top bit set in which case it is an index into the outPointers + - otherwise the oop is a byte offset from the start of the first object in the segment and is in oopMap. + The method is written to avoid large integer arithmetic as much as possible." + | lo hi topBit oop | + lo := self readUint32. + hi := self readUint32. + topBit := hi bitShift: -31. + ^(lo bitAnd: 7) caseOf: { + [0] -> [topBit = 1 + ifTrue: + [oop := (hi - 16r80000000 bitShift: 32) + lo. + outPointers at: oop / 8 + 1] + ifFalse: + [oop := (hi bitShift: 32) + lo. + oopMap at: oop]]. + [1] -> [(lo bitShift: -3) bitOr: (hi - (topBit = 1 ifTrue: [16r100000000] ifFalse: [0]) bitShift: 29)]. + [2] -> [Character value: ((lo bitShift: -3) bitOr: (hi bitShift: 29))]. + [4] -> [(hi = 0 and: [lo <= 15]) "+ve & -ve zero" + ifTrue: [lo <= 7 ifTrue: [0.0] ifFalse: [-0.0]] + ifFalse: "convert lo: | tag | sign | mantissa low 28 bits | hi: | mantissa high 24 bits | exponent - 896 | + to hi: | mantissa high 20 bits | exponent 11 bits | sign | lo: | mantissa low 32 bits |" + [^(BoxedFloat64 basicNew: 2) + basicAt: 1 put: ((lo bitAnd: 8) bitShift: 28) + ((hi bitShift: -4) + (896 bitShift: 20)); + basicAt: 2 put: (lo bitShift: -4) + ((hi bitAnd: 15) bitShift: 28); + * 1.0]]} + otherwise: [self error: 'unrecognized tag pattern']! Item was added: + ----- Method: Spur64BitImageSegmentLoader>>validImageSegmentVersion: (in category 'private') ----- + validImageSegmentVersion: threeByteInteger + ^threeByteInteger = 68021! Item was added: + Object subclass: #SpurImageSegmentLoader + instanceVariableNames: 'segment outPointers oopMap position' + classVariableNames: 'TopHashBit' + poolDictionaries: '' + category: 'System-Object Storage'! + + !SpurImageSegmentLoader commentStamp: 'eem 12/15/2017 11:20' prior: 0! + SpurImageSegmentLoader is the abstract class for loaders of 32-bit and 64-bit Spur image segments. The VM has both storing and loading primitives and the store primitive is always used. The load primitive is used when the word size of the current system matches that of the stored segment (orf the word size of the system in which the segment was stored). A word on encoding. The keys in oopMap are byte positions of the start of the object, offset by the 64-bit version stamp. So the first object, which has oop 0, is in the map at 0, and corresponds to index 3 in the segment data. + + position starts at zero and readUInt32 increments position by 4 before using uint32At: to access segment. Hence the first access via readUInt32 is of index 1 in segment data. Later on position is reset to 8 bytes beyond the oop to access the data. + + Instance Variables + oopMap: <Dictionary of: oop (Integer) -> object> + outPointers: <Array> + position: <Integer> + segment: <WordArrayForSegment> + + oopMap + - the map from the oop of an object to the object with that oop + + outPointers + - the array of imported objects, objects not in the segment but referred to by the segment + + position + - the current position when parsing the segment + + segment + - the segment data, which starts with 64-bits of version stamp, so the first object starts at index 3, and has oop 0. + ! Item was added: + ----- Method: SpurImageSegmentLoader>>allocate16BitObject:size: (in category 'reading') ----- + allocate16BitObject: class size: nShorts + (class isBits and: [class isShorts]) ifFalse: + [self error: 'shorts class expected']. + ^class basicNew: nShorts! Item was added: + ----- Method: SpurImageSegmentLoader>>allocate32BitObject:size: (in category 'reading') ----- + allocate32BitObject: class size: nWords + (class isBits and: [class isWords]) ifFalse: + [self error: 'words class expected']. + ^class basicNew: nWords! Item was added: + ----- Method: SpurImageSegmentLoader>>allocate64BitObject:size: (in category 'reading') ----- + allocate64BitObject: class size: nLongs + (class isBits and: [class isLongs]) ifFalse: + [self error: 'longs class expected']. + ^class basicNew: nLongs! Item was added: + ----- Method: SpurImageSegmentLoader>>allocate8BitObject:size: (in category 'reading') ----- + allocate8BitObject: class size: nBytes + class isBytes ifFalse: + [self error: 'bytes class expected']. + ^class basicNew: nBytes! Item was added: + ----- Method: SpurImageSegmentLoader>>allocateCompiledCode:size: (in category 'reading') ----- + allocateCompiledCode: class size: nBytes + "Allocate a CompiledCode object. nBytes must be reduced + by the number of objects in the method (header and literals)." + self subclassResponsibility! Item was added: + ----- Method: SpurImageSegmentLoader>>allocateFixedAndVariableObject:size: (in category 'reading') ----- + allocateFixedAndVariableObject: class size: nSlots + (class isPointers and: [class isVariable]) ifFalse: + [self error: 'variable pointers class expected']. + ^class basicNew: nSlots - class instSize! Item was added: + ----- Method: SpurImageSegmentLoader>>allocateFixedSizeObject:size: (in category 'reading') ----- + allocateFixedSizeObject: class size: instSize + (class isPointers and: [class isFixed]) ifFalse: + [self error: 'fixed pointers class expected']. + class instSize = instSize ifFalse: [self halt]. + ^class basicNew! Item was added: + ----- Method: SpurImageSegmentLoader>>allocateObject:classIndex:slots: (in category 'reading') ----- + allocateObject: format classIndex: classIndex slots: numSlots + | class | + class := (self classIndexInOutPointers: classIndex) + ifTrue: [outPointers at: (self outPointerIndexForClassIndex: classIndex)] + ifFalse: [oopMap at: (self oopIndexForClassIndex: classIndex)]. + (format <= 1 or: [format = 5"ephemerons"]) ifTrue: + [^self allocateFixedSizeObject: class size: numSlots]. + format = 2 ifTrue: + [^self allocateVariableSizeObject: class size: numSlots]. + (format between: 3 and: 4) ifTrue: + [^self allocateFixedAndVariableObject: class size: numSlots]. + format >= 16 ifTrue: + [| nBytes | + nBytes := numSlots * 8 - (format bitAnd: 7). + format >= 24 ifTrue: + [^self allocateCompiledCode: class size: nBytes]. + ^self allocate8BitObject: class size: nBytes]. + format >= 12 ifTrue: + [| nShorts | + nShorts := numSlots * 4 - (format bitAnd: 3). + ^self allocate16BitObject: class size: nShorts]. + format >= 10 ifTrue: + [| nWords | + nWords := numSlots * 2 - (format bitAnd: 1). + ^self allocate32BitObject: class size: nWords]. + format = 9 ifTrue: + [^self allocate64BitObject: class size: numSlots]. + format = 33 ifTrue: + [^self allocateAndPartFillClassObject: class size: numSlots]. + self error: 'Unknown object format'! Item was added: + ----- Method: SpurImageSegmentLoader>>allocateVariableSizeObject:size: (in category 'reading') ----- + allocateVariableSizeObject: class size: numSlots + (class isPointers and: [class isVariable]) ifFalse: + [self error: 'variable pointers class expected']. + ^class basicNew: numSlots! Item was added: + ----- Method: SpurImageSegmentLoader>>checkValidFormat: (in category 'private') ----- + checkValidFormat: formatPlusRememberedBit + "valid formats: + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 unused, reserved for exotic pointer objects? + 7 Forwarded Object, 1st field is pointer, rest of fields are ignored + 8 unused, reserved for exotic non-pointer objects? + 9 64-bit indexable + 10 - 11 32-bit indexable (11 unused in 32 bits) + 12 - 15 16-bit indexable (14 & 15 unused in 32-bits) + 16 - 23 byte indexable (20-23 unused in 32-bits) + 24 - 31 compiled method (28-31 unused in 32-bits)" + self assert: (formatPlusRememberedBit between: 6 and: 8) not. + self assert: (formatPlusRememberedBit < 32 + or: [formatPlusRememberedBit = 33 "classes are non-indexable"])! Item was added: + ----- Method: SpurImageSegmentLoader>>classIndexInOutPointers: (in category 'private') ----- + classIndexInOutPointers: classIndex + "If the top bit of a classIndex is set it is that of a class imported from outPointers" + ^classIndex anyMask: 16r200000! Item was added: + ----- Method: SpurImageSegmentLoader>>fillBytes:oop: (in category 'filling') ----- + fillBytes: object oop: oop + | word | + word := self readUint32. + 1 to: object basicSize do: + [:i | object basicAt: i put: (word bitAnd: 16rFF). + word := (i bitAnd: 3) = 0 + ifTrue: [self readUint32] + ifFalse: [word >> 8]]. + ^object! Item was added: + ----- Method: SpurImageSegmentLoader>>fillCompiledCode:oop: (in category 'filling') ----- + fillCompiledCode: codeObject oop: oop + | header startMinusOne numBytes word | + header := self readOop. + 1 to: codeObject numLiterals do: + [:i | codeObject literalAt: i put: self readOop]. + startMinusOne := codeObject initialPC - 1. + numBytes := codeObject basicSize - startMinusOne. + word := self readUint32. + 1 to: numBytes do: + [:i | + codeObject basicAt: startMinusOne + i put: (word bitAnd: 16rFF). + word := (i bitAnd: 3) = 0 + ifTrue: [self readUint32] + ifFalse: [word >> 8]]. + ^codeObject! Item was added: + ----- Method: SpurImageSegmentLoader>>fillContext:oop: (in category 'filling') ----- + fillContext: ctx oop: oop + 1 to: ctx class instSize do: + [:i | ctx instVarAt: i put: self readOop]. + 1 to: ctx stackPtr do: + [:i | ctx basicAt: i put: self readOop]. + ^ctx! Item was added: + ----- Method: SpurImageSegmentLoader>>fillObject:oop: (in category 'filling') ----- + fillObject: object oop: oop + "Fill the object's inst vars with data/other objects." + | class | + "First set position to 4 bytes before the first field, in readiness to read the object's data" + position := oop + 16. "8 bytes of version stamp + 8 bytes of object header - 4 bytes of preincrement + 4 bytes 0->1 relative index" + class := object class. + class isPointers ifTrue: + [class isVariable ifTrue: + [object isContext ifTrue: + [^self fillContext: object oop: oop]. + ^self fillVariablePointers: object oop: oop]. + object isBehavior ifTrue: + [^self fillBehavior: object oop: oop]. + ^self fillPointers: object oop: oop]. + class isBytes ifTrue: + [object isCompiledCode ifTrue: + [^self fillCompiledCode: object oop: oop]. + ^self fillBytes: object oop: oop]. + class isWords ifTrue: + [^self fillWords: object oop: oop]. + class isLongs ifTrue: + [^self fillWords: object oop: oop]. + ^self fillShorts: object oop: oop! Item was added: + ----- Method: SpurImageSegmentLoader>>fillPointers:oop: (in category 'filling') ----- + fillPointers: object oop: objOop + 1 to: object class instSize do: + [:index| + object instVarAt: index put: self readOop]. + ^object! Item was added: + ----- Method: SpurImageSegmentLoader>>fillVariablePointers:oop: (in category 'filling') ----- + fillVariablePointers: object oop: objOop + 1 to: object class instSize do: + [:index| + object instVarAt: index put: self readOop]. + 1 to: object basicSize do: + [:index| + object basicAt: index put: self readOop]. + ^object! Item was added: + ----- Method: SpurImageSegmentLoader>>fillWords:oop: (in category 'reading') ----- + fillWords: object oop: oop + 1 to: object basicSize do: + [:i | + object basicAt: i put: self readUint32]. + ^object! Item was added: + ----- Method: SpurImageSegmentLoader>>ignoringAccessToWordAfterSegmentDo: (in category 'filling') ----- + ignoringAccessToWordAfterSegmentDo: aBlock + "Both fillBytes:oop: and fillShorts:oop: may read an extra word beyond the end of data. + If the object is the last in the segment this will cause an out-of-bounds error. + Squash this error." + ^aBlock + on: Error "Why do we still not have SubscriptOutOfBounds or some such??" + do: [:ex| + ex messageText = ('subscript is out of bounds: ', (segment size + 1) printString) ifFalse: + [ex pass]. + ex + searchFrom: (ex signalerContext findContextSuchThat: [:ctxt| ctxt selector == #uint32At:]); + resumeUnchecked: 0]! Item was added: + ----- Method: SpurImageSegmentLoader>>loadSegmentFrom:outPointers: (in category 'loading') ----- + loadSegmentFrom: segmentWordArray outPointers: outPointerArray + | version end memory | + segment := segmentWordArray. + outPointers := outPointerArray. + position := 0. + version := self readUint32. + (self validImageSegmentVersion: (version bitAnd: 16rFFFFFF)) ifFalse: + [^self error: 'Cannot read this segment (endianness?)']. + "First allocate all objects, then fill in their fields via oopMap" + memory := OrderedCollection new: 1000. + oopMap := Dictionary new. + end := segment size * 4. + position := 8. + [position < end] whileTrue: + [memory addLast: self readObject]. + self ignoringAccessToWordAfterSegmentDo: + [oopMap keysAndValuesDo: + [:oop :obj | self fillObject: obj oop: oop]]. + "Answer list of all objects (unlike primitive, which returned the first object and relied on other objects being consecutive in memory)" + ^memory! Item was added: + ----- Method: SpurImageSegmentLoader>>oopIndexForClassIndex: (in category 'private') ----- + oopIndexForClassIndex: classIndex + "Whebn a classIndex doesn't have the topBit set it maps to an oop in the segment thusly:" + ^classIndex - 16 "self firstClassIndexPun" * 8 "self allocationUnit"! Item was added: + ----- Method: SpurImageSegmentLoader>>outPointerIndexForClassIndex: (in category 'private') ----- + outPointerIndexForClassIndex: classIndex + "If the top bit of a classIndex is set it is that of a class imported from outPointers" + ^classIndex - 16r1FFFFF "a.k.a. classIndex - 16r200000 + 1"! Item was added: + ----- Method: SpurImageSegmentLoader>>readObject (in category 'reading') ----- + readObject + "Read the header and the class of the object, instantiate it, and store it in oopMap at its oop." + self subclassResponsibility! Item was added: + ----- Method: SpurImageSegmentLoader>>readOop (in category 'reading') ----- + readOop + "Read an oop and map it to an object: + - The oop may be immediate in which case its tag indicates its class and the remeaining bits its value. + - the oop may have its top bit set in which case it is an index into the outPointers + - otherwise the oop is a byte offset from the start of the first object in the segment and is in oopMap." + self subclassResponsibility! Item was added: + ----- Method: SpurImageSegmentLoader>>readUint32 (in category 'reading') ----- + readUint32 + ^self uint32At: (position := position + 4)! Item was added: + ----- Method: SpurImageSegmentLoader>>uint32At: (in category 'reading') ----- + uint32At: addr + "TODO: do endian conversion here" + "also read the class comment" + ^segment at: addr // 4! Item was added: + ----- Method: SpurImageSegmentLoader>>validImageSegmentVersion: (in category 'private') ----- + validImageSegmentVersion: threeByteInteger + self subclassResponsibility!

1 0

The Trunk: MorphicTests-mt.45.mcz
by commits＠source.squeak.org 15 Dec '17

15 Dec '17

Marcel Taeumel uploaded a new version of MorphicTests to project The Trunk: http://source.squeak.org/trunk/MorphicTests-mt.45.mcz ==================== Summary ==================== Name: MorphicTests-mt.45 Author: mt Time: 15 December 2017, 2:41:31.499738 pm UUID: b37c9408-de4e-c241-97ea-ca024031cf67 Ancestors: MorphicTests-dtl.44 Adds test for focus events and reject bug. =============== Diff against MorphicTests-dtl.44 =============== Item was changed: Morph subclass: #MorphForEventTests + instanceVariableNames: 'eventsDuringCapture eventsDuringBubble eventsRejected eventsFiltered handlesMouseDown keyStrokesReceived fullFocusDispatch' - instanceVariableNames: 'eventsDuringCapture eventsDuringBubble eventsRejected eventsFiltered handlesMouseDown keyStrokesReceived' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Events'! Item was added: + ----- Method: MorphForEventTests>>fullFocusDispatch (in category 'accessing') ----- + fullFocusDispatch + ^ fullFocusDispatch ifNil: [false]! Item was added: + ----- Method: MorphForEventTests>>fullFocusDispatch: (in category 'accessing') ----- + fullFocusDispatch: aBoolean + fullFocusDispatch := aBoolean.! Item was added: + ----- Method: MorphForEventTests>>processFocusEvent:using: (in category 'events-processing') ----- + processFocusEvent: anEvent using: defaultDispatcher + + ^ self fullFocusDispatch + ifTrue: [defaultDispatcher dispatchFocusEventFully: anEvent with: self] + ifFalse: [defaultDispatcher dispatchFocusEvent: anEvent with: self] + + + ! Item was added: + ----- Method: MorphicEventDispatcherTests>>test11FocusEventReject (in category 'tests') ----- + test11FocusEventReject + "If a morph with mouse focus or keyboard focus rejects the event, that focus should be cleared." + + | m1 m2 | + m1 := MorphForEventTests new. + m1 fullFocusDispatch: false. + m1 on: #mouseDown send: #hide to: m1. + m1 on: #keyStroke send: #hide to: m1. + m1 openInWorld: world. + + hand newMouseFocus: m1. + hand handleEvent: (self redMouseDownAt: m1 center). + self assert: hand mouseFocus isNil. + + hand newKeyboardFocus: m1. + hand handleEvent: (self keystroke: $x at: m1 center). + self assert: hand keyboardFocus isNil. + + m2 := MorphForEventTests new. + m2 bounds: m1 bounds. + m1 addMorph: m2. + m1 fullFocusDispatch: true. + + hand newMouseFocus: m1. + hand handleEvent: (self redMouseDownAt: m2 center). + self assert: hand mouseFocus isNil. + + hand newKeyboardFocus: m2. + hand handleEvent: (self keystroke: $x at: m2 center). + self assert: hand keyboardFocus isNil. + !

1 0

The Trunk: Morphic-mt.1377.mcz
by commits＠source.squeak.org 15 Dec '17

15 Dec '17

Marcel Taeumel uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-mt.1377.mcz ==================== Summary ==================== Name: Morphic-mt.1377 Author: mt Time: 15 December 2017, 2:18:43.656611 pm UUID: 9a7a0a92-9e24-b844-a5ab-d1f0e2ffa7af Ancestors: Morphic-mt.1376 Fixes a bug in Morphic event dispatcher that affects focus events. For example, hiding a morph on #mouseDown: would render the environment unresponsive until something clears the mouse focus again. =============== Diff against Morphic-mt.1376 =============== Item was changed: ----- Method: MorphicEventDispatcher>>dispatchFocusEvent:with: (in category 'focus events') ----- dispatchFocusEvent: anEventWithGlobalPosition with: focusMorph "Dispatch the given event to the given morph. Simulate capturing phase, handle the event, then do bubbling." | currentEvent | "1) Capturing phase." currentEvent := self doCapturingForFocusEvent: anEventWithGlobalPosition with: focusMorph. + currentEvent == #rejected ifTrue: [ + "See implementors of #rejectsEvent:, which is usually based on receiver state and not event state. Thus, reset foci to avoid unresponsive environment." + anEventWithGlobalPosition hand + releaseKeyboardFocus: focusMorph; + releaseMouseFocus: focusMorph. + ^ #rejected]. + "No need to reset foci here for ignored events because not all events might be ignored. Unlike #rejected." - currentEvent == #rejected ifTrue: [^ #rejected]. currentEvent wasIgnored ifTrue: [^ currentEvent]. "2) No sub-tree processing here. Use #dispatchFocusEventFully:with: if you want that, too." "3) Let the focus morph handle the event." currentEvent := self doHandlingForFocusEvent: currentEvent with: focusMorph. currentEvent wasIgnored ifTrue: [^ currentEvent]. "4) Bubbling phase" ^ self doBubblingForFocusEvent: currentEvent with: focusMorph! Item was changed: ----- Method: MorphicEventDispatcher>>dispatchFocusEventFully:with: (in category 'focus events') ----- dispatchFocusEventFully: anEventWithGlobalPosition with: focusMorph "Dispatch the given event to the given morph. Do capturing, processing in sub-tree, and bubbling." | currentEvent | "1) Capturing phase." currentEvent := self doCapturingForFocusEvent: anEventWithGlobalPosition with: focusMorph. + currentEvent == #rejected ifTrue: [ + "See implementors of #rejectsEvent:, which is usually based on receiver state and not event state. Thus, reset foci to avoid unresponsive environment." + anEventWithGlobalPosition hand + releaseKeyboardFocus: focusMorph; + releaseMouseFocus: focusMorph. + ^ #rejected]. + "No need to reset foci here for ignored events because not all events might be ignored. Unlike #rejected." - currentEvent == #rejected ifTrue: [^ #rejected]. currentEvent wasIgnored ifTrue: [^ currentEvent]. "2) Sub-tree processing." currentEvent := self doProcessingForFocusEvent: currentEvent with: focusMorph. currentEvent wasIgnored ifTrue: [^ currentEvent]. "3) Let the focus morph handle the event. Usually no effect because previous sub-tree processing involved the focus morph already -- at least in the bubbling phase. Skip it?" currentEvent := self doHandlingForFocusEvent: currentEvent with: focusMorph. currentEvent wasIgnored ifTrue: [^ currentEvent]. "4) Bubbling phase." ^ self doBubblingForFocusEvent: currentEvent with: focusMorph!

1 0

← Newer
1
2
3
4
5
6
7
8
9
10
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages December 2017