'From Croquet1.0beta of 11 April 2006 [latest update: #1] on 6 August 2008 at 12:53:09 pm'! !ClassBuilder methodsFor: 'private' stamp: 'eem 7/21/2008 14:16'! tooDangerousClasses "Return a list of class names which will not be modified in the public interface" ^#( "Object will break immediately" ProtoObject Object "Contexts and their superclasses" InstructionStream ContextPart BlockContext MethodContext BlockClosure "Superclasses of basic collections" Collection SequenceableCollection ArrayedCollection "Collections known to the VM" Array Bitmap String Symbol ByteArray CompiledMethod TranslatedMethod "Basic Numbers" Magnitude Number SmallInteger Float "Misc other" LookupKey Association Link Point Rectangle Behavior PositionableStream UndefinedObject ) ! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 7/21/2008 12:10'! copyFromRootsForExport: rootArray "When possible, use copySmartRootsExport:. This way may not copy a complete tree of objects. Add to roots: all of the methods pointed to from the outside by blocks." | newRoots list segSize symbolHolder | arrayOfRoots := rootArray. Smalltalk forgetDoIts. "self halt." symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers, so they will be in outPointers" (newRoots := self rootsIncludingPlayers) ifNotNil: [ arrayOfRoots := newRoots]. "world, presenter, and all Player classes" "Creation of the segment happens here" self copyFromRoots: arrayOfRoots sizeHint: 0. segSize := segment size. [(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [ arrayOfRoots := newRoots. self copyFromRoots: arrayOfRoots sizeHint: segSize]. "with methods pointed at from outside" [(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [ arrayOfRoots := newRoots. self copyFromRoots: arrayOfRoots sizeHint: segSize]. "with methods, blocks from outPointers" "classes of receivers of blocks" list := self compactClassesArray. outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). "Zap sender of a homeContext. Can't send live stacks out." 1 to: outPointers size do: [:ii | (outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil]. (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]]. symbolHolder.! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 7/21/2008 14:18'! copySmartRootsExport: rootArray "Use SmartRefStream to find the object. Make them all roots. Create the segment in memory. Project should be in first five objects in rootArray." | newRoots list segSize symbolHolder dummy replacements naughtyBlocks goodToGo allClasses sizeHint proj | Smalltalk forgetDoIts. "self halt." symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers, so they will be in outPointers" dummy := ReferenceStream on: (DummyStream on: nil). "Write to a fake Stream, not a file" "Collect all objects" dummy insideASegment: true. "So Uniclasses will be traced" dummy rootObject: rootArray. "inform him about the root" dummy nextPut: rootArray. (proj :=dummy project) ifNotNil: [self dependentsSave: dummy]. allClasses := SmartRefStream new uniClassInstVarsRefs: dummy. "catalog the extra objects in UniClass inst vars. Put into dummy" allClasses do: [:cls | dummy references at: cls class put: false. "put Player5 class in roots" dummy blockers removeKey: cls class ifAbsent: []]. "refs := dummy references." arrayOfRoots := self smartFillRoots: dummy. "guaranteed none repeat" self savePlayerReferences: dummy references. "for shared References table" replacements := dummy blockers. dummy project "recompute it" ifNil: [self error: 'lost the project!!']. dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project']. dummy := nil. "force GC?" naughtyBlocks := arrayOfRoots select: [ :each | (each isKindOf: ContextPart) and: [each hasInstVarRef] ]. "since the caller switched ActiveWorld, put the real one back temporarily" naughtyBlocks isEmpty ifFalse: [ World becomeActiveDuring: [ goodToGo := (UIManager default chooseFrom: #('keep going' 'stop and take a look') title: 'Some block(s) which reference instance variables are included in this segment. These may fail when the segment is loaded if the class has been reshaped. What would you like to do?') == 1. goodToGo ifFalse: [ naughtyBlocks inspect. self error: 'Here are the bad blocks']. ]. ]. "Creation of the segment happens here" "try using one-quarter of memory min: four megs to publish (will get bumped later)" sizeHint := (Smalltalk garbageCollect // 4 // 4) min: 1024*1024. self copyFromRoots: arrayOfRoots sizeHint: sizeHint areUnique: true. segSize := segment size. [(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [ arrayOfRoots := newRoots. self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. "with methods pointed at from outside" [(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [ arrayOfRoots := newRoots. self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. "with methods, blocks from outPointers" list := self compactClassesArray. outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). 1 to: outPointers size do: [:ii | (outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil]. (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]. "substitute new object in outPointers" (replacements includesKey: (outPointers at: ii)) ifTrue: [ outPointers at: ii put: (replacements at: (outPointers at: ii))]]. proj ifNotNil: [self dependentsCancel: proj]. symbolHolder.! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 7/21/2008 12:11'! 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]. anOut := nil]. "don't hang onto it" [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! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 7/21/2008 12:10'! 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." | object sets receiverClasses inSeg | object := segment. sets := OrderedCollection new. "have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one." receiverClasses := IdentitySet new. inSeg := true. [object := object nextObject. object == endMarker ifTrue: [inSeg := false]. "off end" object isInMemory ifTrue: [ (object isKindOf: Set) ifTrue: [sets add: object]. object isBlock ifTrue: [inSeg ifTrue: [ receiverClasses add: object receiver class]]. object class == MethodContext ifTrue: [inSeg ifTrue: [ receiverClasses add: object receiver class]]. ]. object == 0] whileFalse. sets do: [:each | each rehash]. "our purpose" ^ receiverClasses "our secondary job" ! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 7/21/2008 12:09'! storeDataOn: aDataStream "Don't wrote the array of Roots. Also remember the structures of the classes of objects inside the segment." | tempRoots tempOutP list | state = #activeCopy ifFalse: [self error: 'wrong state']. "real state is activeCopy, but we changed it will be right when coming in" tempRoots := arrayOfRoots. tempOutP := outPointers. outPointers := outPointers clone. self prepareToBeSaved. arrayOfRoots := nil. state := #imported. super storeDataOn: aDataStream. "record my inst vars" arrayOfRoots := tempRoots. outPointers := tempOutP. state := #activeCopy. aDataStream references at: #AnImageSegment put: false. "the false is meaningless" "This key in refs is the flag that there is an ImageSegment in this file." "Find the receivers of blocks in the segment. Need to get the structure of their classes into structures. Put the receivers into references." (aDataStream byteStream isKindOf: DummyStream) ifTrue: [ list := Set new. arrayOfRoots do: [:ea | ea isBlock | (ea class == MethodContext) ifTrue: [ list add: ea receiver class ]]. aDataStream references at: #BlockReceiverClasses put: list]. ! ! !MessageSend methodsFor: 'tiles' stamp: 'eem 7/21/2008 12:09'! stringFor: anObject "Return a string suitable for compiling. Literal or reference from global ref dictionary. self is always named via the ref dictionary." | generic aName | anObject isLiteral ifTrue: [^ anObject printString]. anObject class == Color ifTrue: [^ anObject printString]. anObject class superclass == Boolean ifTrue: [^ anObject printString]. anObject isBlock ifTrue: [^ '[''do nothing'']']. "default block" "Real blocks need to construct tiles in a different way" anObject class isMeta ifTrue: ["a class" ^ anObject name]. generic := anObject knownName. "may be nil or 'Ellipse' " aName := anObject uniqueNameForReference. generic ifNil: [(anObject respondsTo: #renameTo:) ifTrue: [anObject renameTo: aName] ifFalse: [aName := anObject storeString]]. "for Fraction, LargeInt, etc" ^ aName ! ! !MethodFinder methodsFor: 'search' stamp: 'eem 7/21/2008 12:08'! testPerfect: aSelector "Try this selector!! Return true if it answers every example perfectly. Take the args in the order they are. Do not permute them. Survive errors. later cache arg lists." | sz argList val rec activeSel perform | "Transcript cr; show: aSelector. debug" perform := aSelector beginsWith: 'perform:'. sz := argMap size. 1 to: thisData size do: [:ii | "each example set of args" argList := (thisData at: ii) copyFrom: 2 to: sz. perform ifFalse: [activeSel := aSelector] ifTrue: [activeSel := argList first. "what will be performed" ((Approved includes: activeSel) or: [AddAndRemove includes: activeSel]) ifFalse: [^ false]. "not approved" aSelector == #perform:withArguments: ifTrue: [activeSel numArgs = (argList at: 2) basicSize "avoid error" ifFalse: [^ false]] ifFalse: [activeSel numArgs = (aSelector numArgs - 1) ifFalse: [^ false]]]. 1 to: sz do: [:num | (Blocks includes: (Array with: activeSel with: num)) ifTrue: [ (argList at: num) isBlock ifFalse: [^ false]]]. rec := (AddAndRemove includes: activeSel) ifTrue: [(thisData at: ii) first isSymbol ifTrue: [^ false]. "vulnerable to modification" (thisData at: ii) first copyTwoLevel] "protect from damage" ifFalse: [(thisData at: ii) first]. val := [rec perform: aSelector withArguments: argList] ifError: [:aString :aReceiver | "self test3." "self test2: (thisData at: ii)." ^ false]. "self test3." "self test2: (thisData at: ii)." ((answers at: ii) closeTo: val) ifFalse: [^ false]. ]. ^ true! ! !UpdatingMenuItemMorph methodsFor: 'enablement' stamp: 'eem 7/21/2008 12:07'! enablementSelector: aSelector enablementSelector := aSelector isBlock ifTrue: [aSelector copyForSaving] ifFalse: [aSelector] ! ! "Postscript: Eliminate the prototype BlockContext from the specialObjectsArray. The VM doesn't use it. This paves the way for removing BlockCOntext altogether and merging ContextPart and MethodContext into e.g. Context." (Smalltalk specialObjectsArray at: 38) class == BlockContext ifTrue: [Smalltalk specialObjectsArray at: 38 put: nil]!