'From Squeak3.7alpha of ''11 September 2003'' [latest update: #5420] on 11 October 2003 at 11:40:50 am'! "Change Set: KCP-0095-extractVMFromSystDict Date: 27 June 2003 Author: stephane ducasse Define a new class SmalltalkImage that represents all the SystemDictionary behavior related to SmalltalkImage management. Following Tim suggestion this class will merge all the aspects of VM+Image management. This is the first changeset of a long series. v3: SmalltalkImage current "! Object subclass: #SmalltalkImage instanceVariableNames: '' classVariableNames: 'LastStats SourceFileVersionString ' poolDictionaries: '' category: 'System-Support'! !SmalltalkImage commentStamp: 'sd 7/2/2003 21:50' prior: 0! I represent the SmalltalkImage and partly the VM. Using my current instance you can - get the value of some VM parameters, system arguments, vm profiling, endianess status, external objects,.... - save the image, manage sources As you will notice browsing my code I'm a fat class having still too much responsibility. But this is life. sd-2 July 2003 PS: if someone wants to split me go ahead.! SmalltalkImage class instanceVariableNames: 'current '! IdentityDictionary subclass: #SystemDictionary instanceVariableNames: 'cachedClassNames ' classVariableNames: 'LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore MemoryHogs ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp SystemChanges VersionString ' poolDictionaries: '' category: 'System-Support'! !AbstractSound methodsFor: 'file i/o' stamp: 'sd 9/30/2003 13:41'! storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files). If self isStereo is true, both channels are stored, creating a stereo file. Otherwise, only the left channel is stored, creating a mono file." | bufSize stereoBuffer reverseBytes remaining out | self reset. bufSize _ (2 * self samplingRate rounded) min: samplesToStore. "two second buffer" stereoBuffer _ SoundBuffer newStereoSampleCount: bufSize. reverseBytes _ bigEndianFlag ~= (SmalltalkImage current isBigEndian). 'Storing audio...' displayProgressAt: Sensor cursorPoint from: 0 to: samplesToStore during: [:bar | remaining _ samplesToStore. [remaining > 0] whileTrue: [ bar value: samplesToStore - remaining. stereoBuffer primFill: 0. "clear the buffer" self playSampleCount: (bufSize min: remaining) into: stereoBuffer startingAt: 1. self isStereo ifTrue: [out _ stereoBuffer] ifFalse: [out _ stereoBuffer extractLeftChannel]. reverseBytes ifTrue: [out reverseEndianness]. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization for files: write sound buffer directly to file" aBinaryStream next: (out size // 2) putAll: out startingAt: 1] "size in words" ifFalse: [ "for non-file streams:" 1 to: out monoSampleCount do: [:i | aBinaryStream int16: (out at: i)]]. remaining _ remaining - bufSize]]. ! ! !ContextPart methodsFor: 'debugger access' stamp: 'sd 9/30/2003 13:55'! errorReportOn: strm "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." | cnt aContext startPos | strm print: Date today; space; print: Time now; cr. strm cr. strm nextPutAll: 'VM: '; nextPutAll: SmalltalkImage current platformName asString; nextPutAll: ' - '; nextPutAll: SmalltalkImage current vmVersion asString; cr. strm nextPutAll: 'Image: '; nextPutAll: SystemVersion current version asString; nextPutAll: ' ['; nextPutAll: Smalltalk lastUpdateString asString; nextPutAll: ']'; cr. strm cr. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." cnt _ 0. startPos _ strm position. aContext _ self. [aContext == nil] whileFalse: [[(cnt _ cnt + 1) < 5] whileTrue: [aContext printDetails: strm. "variable values" strm cr. aContext _ aContext sender]. strm cr; nextPutAll: '--- The full stack ---'; cr. aContext _ self. cnt _ 0. [aContext == nil] whileFalse: [cnt _ cnt + 1. cnt = 5 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. strm print: aContext; cr. "just class>>selector" strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. "exit early" cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. aContext _ aContext sender]]! ! !Form methodsFor: 'resources' stamp: 'sd 9/30/2003 13:41'! storeResourceOn: aStream "Store a resource representation of the receiver on aStream. Must be specific to the receiver so that no code is filed out." self hibernate. aStream nextPutAll: self resourceTag asByteArray. "tag" aStream nextNumber: 4 put: width. aStream nextNumber: 4 put: height. aStream nextNumber: 4 put: depth. (bits isMemberOf: ByteArray) ifFalse:[ "must store bitmap" aStream nextNumber: 4 put: 0. "tag" aStream nextNumber: 4 put: (SmalltalkImage current isBigEndian ifTrue:[1] ifFalse:[0]). ]. aStream nextNumber: 4 put: bits size. aStream nextPutAll: bits. ! ! !LoopedSampledSound methodsFor: 'file i/o' stamp: 'sd 9/30/2003 13:41'! storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files)." | reverseBytes | (self isStereo or: [self samplingRate ~= originalSamplingRate]) ifTrue: [ ^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream]. "optimization: if I'm not stereo and sampling rates match, just store my buffer" reverseBytes _ bigEndianFlag ~= SmalltalkImage current isBigEndian. reverseBytes ifTrue: [leftSamples reverseEndianness]. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization for files: write sound buffer directly to file" aBinaryStream next: (leftSamples size // 2) putAll: leftSamples startingAt: 1] "size in words" ifFalse: [ "for non-file streams:" 1 to: leftSamples monoSampleCount do: [:i | aBinaryStream int16: (leftSamples at: i)]]. reverseBytes ifTrue: [leftSamples reverseEndianness]. "restore to original endianness" ! ! !MPEGFile methodsFor: 'access' stamp: 'sd 9/30/2003 13:41'! endianness ^endianness isNil ifTrue: [endianness _ SmalltalkImage current endianness] ifFalse: [endianness]! ! !MessageTally methodsFor: 'initialize-release' stamp: 'sd 9/30/2003 13:42'! spyEvery: millisecs on: aBlock "Create a spy and spy on the given block at the specified rate." | myDelay value startTime time0 | (aBlock isMemberOf: BlockContext) ifFalse: [self error: 'spy needs a block here']. self class: aBlock receiver class method: aBlock method. "set up the probe" ObservedProcess _ Processor activeProcess. myDelay := Delay forMilliseconds: millisecs. time0 := Time millisecondClockValue. gcStats _ SmalltalkImage current getVMParameters. Timer := [[true] whileTrue: [startTime := Time millisecondClockValue. myDelay wait. self tally: ObservedProcess suspendedContext "tally can be > 1 if ran a long primitive" by: (Time millisecondClockValue - startTime) // millisecs]. nil] newProcess. Timer priority: Processor userInterruptPriority. "activate the probe and evaluate the block" Timer resume. value := aBlock value. "Collect gc statistics" SmalltalkImage current getVMParameters keysAndValuesDo: [:idx :gcVal| gcStats at: idx put: (gcVal - gcStats at: idx)]. "cancel the probe and return the value" Timer terminate. time := Time millisecondClockValue - time0. ^value! ! !MessageTally methodsFor: 'initialize-release' stamp: 'sd 9/30/2003 13:42'! spyEvery: millisecs onProcess: aProcess forMilliseconds: msecDuration "Create a spy and spy on the given process at the specified rate." | myDelay time0 endTime sem | (aProcess isKindOf: Process) ifFalse: [self error: 'spy needs a Process here']. self class: aProcess suspendedContext receiver class method: aProcess suspendedContext method. "set up the probe" ObservedProcess _ aProcess. myDelay _ Delay forMilliseconds: millisecs. time0 _ Time millisecondClockValue. endTime _ time0 + msecDuration. sem _ Semaphore new. gcStats _ SmalltalkImage current getVMParameters. Timer _ [[| startTime | startTime _ Time millisecondClockValue. myDelay wait. self tally: ObservedProcess suspendedContext by: Time millisecondClockValue - startTime // millisecs. startTime < endTime] whileTrue. sem signal] forkAt: (ObservedProcess priority + 1 min: Processor highestPriority). "activate the probe and wait for it to finish" sem wait. "Collect gc statistics" SmalltalkImage current getVMParameters keysAndValuesDo: [:idx :gcVal| gcStats at: idx put: (gcVal - gcStats at: idx)]. time _ Time millisecondClockValue - time0! ! !Project methodsFor: 'file in/out' stamp: 'sd 9/30/2003 13:46'! storeToMakeRoom "Write out enough projects to fulfill the space goals. Include the size of the project about to come in." | params memoryEnd goalFree cnt gain proj skip tried | GoalFreePercent ifNil: [GoalFreePercent _ 33]. GoalNotMoreThan ifNil: [GoalNotMoreThan _ 20000000]. params _ SmalltalkImage current getVMParameters. memoryEnd _ params at: 3. " youngSpaceEnd _ params at: 2. free _ memoryEnd - youngSpaceEnd. " goalFree _ GoalFreePercent asFloat / 100.0 * memoryEnd. goalFree _ goalFree min: GoalNotMoreThan. world isInMemory ifFalse: ["enough room to bring it in" goalFree _ goalFree + (self projectParameters at: #segmentSize ifAbsent: [0])]. cnt _ 30. gain _ Smalltalk garbageCollectMost. "skip a random number of projects that are in memory" proj _ self. skip _ 6 atRandom. [proj _ proj nextInstance ifNil: [Project someInstance]. proj world isInMemory ifTrue: [skip _ skip - 1]. skip > 0] whileTrue. cnt _ 0. tried _ 0. [gain > goalFree] whileFalse: [ proj _ proj nextInstance ifNil: [Project someInstance]. proj storeSegment ifTrue: ["Yes, did send its morphs to the disk" gain _ gain + (proj projectParameters at: #segmentSize ifAbsent: [20000]). "a guess" self beep. (cnt _ cnt + 1) > 5 ifTrue: [^ self]]. "put out 5 at most" (tried _ tried + 1) > 23 ifTrue: [^ self]]. "don't get stuck in a loop"! ! !SampledSound methodsFor: 'file i/o' stamp: 'sd 9/30/2003 13:46'! storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files)." | reverseBytes | self samplingRate ~= originalSamplingRate ifTrue: [ ^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream]. "optimization: if sampling rates match, just store my buffer" reverseBytes _ bigEndianFlag ~= SmalltalkImage current isBigEndian. reverseBytes ifTrue: [samples reverseEndianness]. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization for files: write sound buffer directly to file" aBinaryStream next: (samples size // 2) putAll: samples startingAt: 1] "size in words" ifFalse: [ "for non-file streams:" 1 to: samples monoSampleCount do: [:i | aBinaryStream int16: (samples at: i)]]. reverseBytes ifTrue: [samples reverseEndianness]. "restore to original endianness" ! ! !ShortIntegerArray methodsFor: 'objects from disk' stamp: 'sd 9/30/2003 13:46'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." | hack blt | SmalltalkImage current isLittleEndian ifTrue: [ "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 1. blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1" blt sourceX: 1; destX: 0; copyBits. blt sourceX: 0; destX: 1; copyBits. blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3" blt sourceX: 3; destX: 2; copyBits. blt sourceX: 2; destX: 3; copyBits]. ! ! !ShortIntegerArray class methodsFor: 'class initialization' stamp: 'sd 9/30/2003 13:46'! startUpFrom: anImageSegment "In this case, do we need to swap word halves when reading this segement?" ^ (SmalltalkImage current endianness) ~~ (anImageSegment endianness) ifTrue: [Message selector: #swapShortObjects] "will be run on each instance" ifFalse: [nil]. ! ! !ShortRunArray methodsFor: 'objects from disk' stamp: 'sd 9/30/2003 13:46'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." | hack blt | SmalltalkImage current isLittleEndian ifTrue: [ "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 1. blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1" blt sourceX: 1; destX: 0; copyBits. blt sourceX: 0; destX: 1; copyBits. blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3" blt sourceX: 3; destX: 2; copyBits. blt sourceX: 2; destX: 3; copyBits]. ! ! !SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:27'! extraVMMemory "Answer the current setting of the 'extraVMMemory' VM parameter. See the comment in extraVMMemory: for details." ^ self vmParameterAt: 23 ! ! !SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:27'! extraVMMemory: extraBytesToReserve "Request that the given amount of extra memory be reserved for use by the virtual machine to leave extra C heap space available for things like plugins, network and file buffers, and so on. This request is stored when the image is saved and honored when the image is next started up. Answer the previous value of this parameter." extraBytesToReserve < 0 ifTrue: [self error: 'VM memory reservation must be non-negative']. ^ self vmParameterAt: 23 put: extraBytesToReserve ! ! !SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:47'! getVMParameters "Answer an Array containing the current values of the VM's internal parameter/metric registers. Each value is stored in the array at the index corresponding to its VM register. (See #vmParameterAt: and #vmParameterAt:put:.)" "SmalltalkImage current getVMParameters" self primitiveFailed! ! !SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:26'! vmParameterAt: parameterIndex "parameterIndex is a positive integer corresponding to one of the VM's internal parameter/metric registers. Answer with the current value of that register. Fail if parameterIndex has no corresponding register. VM parameters are numbered as follows: 1 end of old-space (0-based, read-only) 2 end of young-space (read-only) 3 end of memory (read-only) 4 allocationCount (read-only) 5 allocations between GCs (read-write) 6 survivor count tenuring threshold (read-write) 7 full GCs since startup (read-only) 8 total milliseconds in full GCs since startup (read-only) 9 incremental GCs since startup (read-only) 10 total milliseconds in incremental GCs since startup (read-only) 11 tenures of surving objects since startup (read-only) 12-20 specific to the translating VM 21 root table size (read-only) 22 root table overflows since startup (read-only) 23 bytes of extra memory to reserve for VM buffers, plugins, etc. 24 memory headroom when growing object memory (rw) 25 memory threshold above which shrinking object memory (rw)" self primitiveFailed! ! !SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:27'! vmParameterAt: parameterIndex put: newValue "parameterIndex is a positive integer corresponding to one of the VM's internal parameter/metric registers. Store newValue (a positive integer) into that register and answer with the previous value that was stored there. Fail if newValue is out of range, if parameterIndex has no corresponding register, or if the corresponding register is read-only." self primitiveFailed! ! !SmalltalkImage methodsFor: 'endian' stamp: 'sd 7/3/2003 22:05'! endianness | bytes word blt | "What endian-ness is the current hardware? The String '1234' will be stored into a machine word. On BigEndian machines (the Mac), $1 will be the high byte if the word. On LittleEndian machines (the PC), $4 will be the high byte." "SmalltalkImage current endianness" bytes _ ByteArray withAll: #(0 0 0 0). "(1 2 3 4) or (4 3 2 1)" word _ WordArray with: 16r01020304. blt _ (BitBlt toForm: (Form new hackBits: bytes)) sourceForm: (Form new hackBits: word). blt combinationRule: Form over. "store" blt sourceY: 0; destY: 0; height: 1; width: 4. blt sourceX: 0; destX: 0. blt copyBits. "paste the word into the bytes" bytes first = 1 ifTrue: [^ #big]. bytes first = 4 ifTrue: [^ #little]. self error: 'Ted is confused'.! ! !SmalltalkImage methodsFor: 'endian' stamp: 'sd 6/27/2003 23:25'! isBigEndian ^self endianness == #big! ! !SmalltalkImage methodsFor: 'endian' stamp: 'sd 6/27/2003 23:25'! isLittleEndian ^self endianness == #little! ! !SmalltalkImage methodsFor: 'external' stamp: 'sd 6/28/2003 18:23'! exitToDebugger "Primitive. Enter the machine language debugger, if one exists. Essential. See Object documentation whatIsAPrimitive. This primitive is to access the debugger when debugging the vm or a plugging in C" self primitiveFailed! ! !SmalltalkImage methodsFor: 'external' stamp: 'sd 6/28/2003 17:38'! unbindExternalPrimitives "Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found." "Do nothing if the primitive fails for compatibility with older VMs" ! ! !SmalltalkImage methodsFor: 'quit' stamp: 'sd 6/28/2003 17:32'! quitPrimitive "Primitive. Exit to another operating system on the host machine, if one exists. All state changes in the object space since the last snapshot are lost. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !SmalltalkImage class methodsFor: 'instance creation' stamp: 'sd 9/30/2003 14:28'! current "Note that this could be implemented differently to avoid the test" current isNil ifTrue: [current := self basicNew]. ^ current! ! !SmalltalkImage class methodsFor: 'instance creation' stamp: 'sd 9/30/2003 13:39'! new self error: 'Use current'.! ! !SmartRefStream methodsFor: 'class changed shape' stamp: 'sd 7/2/2003 22:10'! writeConversionMethodIn: newClass fromInstVars: oldList to: newList renamedFrom: oldName "The method convertToCurrentVersion:refStream: was not found in newClass. Write a default conversion method for the author to modify. If method exists, append new info into the end." | code newOthers oldOthers copied newCode | newOthers _ newList asOrderedCollection "copy". oldOthers _ oldList asOrderedCollection "copy". copied _ OrderedCollection new. newList do: [:instVar | (oldList includes: instVar) ifTrue: [ instVar isInteger ifFalse: [copied add: instVar]. newOthers remove: instVar. oldOthers remove: instVar]]. code _ WriteStream on: (String new: 500). code cr; cr; tab; nextPutAll: '"From ', SystemVersion current version, ' [', Smalltalk lastUpdateString; nextPutAll: '] on ', Date today printString, '"'; cr. code tab; nextPutAll: '"These variables are automatically stored into the new instance: '. code nextPutAll: copied asArray printString; nextPut: $.; cr. code tab; nextPutAll: 'Test for this particular conversion.'; nextPutAll: ' Get values using expressions like (varDict at: ''foo'')."'; cr; cr. (newOthers size = 0) & (oldOthers size = 0) & (oldName == nil) ifTrue: [^ self]. "Instance variables are the same. Only the order changed. No conversion needed." (newOthers size > 0) ifTrue: [ code tab; nextPutAll: '"New variables: ', newOthers asArray printString, '. If a non-nil value is needed, please assign it."'; cr]. (oldOthers size > 0) ifTrue: [ code tab; nextPutAll: '"These are going away ', oldOthers asArray printString, '. Possibly store their info in some other variable?"'; cr]. oldName ifNotNil: [ code tab; nextPutAll: '"Test for instances of class ', oldName, '.'; cr. code tab; nextPutAll: 'Instance vars with the same name have been moved here."'; cr. ]. code tab; nextPutAll: '"Move your code above the ^ super... Delete extra comments."'; cr. (newClass includesSelector: #convertToCurrentVersion:refStream:) ifTrue: ["append to old methods" newCode _ (newClass sourceCodeAt: #convertToCurrentVersion:refStream:), code contents] ifFalse: ["new method" newCode _ 'convertToCurrentVersion: varDict refStream: smartRefStrm', code contents, ' ^ super convertToCurrentVersion: varDict refStream: smartRefStrm']. newClass compile: newCode classified: 'object fileIn'. "If you write a conversion method beware that the class may need a version number change. This only happens when two conversion methods in the same class have the same selector name. (A) The inst var lists of the new and old versions intials as some older set of new and old inst var lists. or (B) Twice in a row, the class needs a conversion method, but the inst vars stay the same the whole time. (For an internal format change.) If either is the case, fileouts already written with the old (wrong) version number, say 2. Your method must be able to read files that say version 2 but are really 3, until you expunge the erroneous version 2 files from the universe." ! ! !SoundBuffer methodsFor: 'utilities' stamp: 'sd 9/30/2003 13:47'! saveAsAIFFFileSamplingRate: rate on: aBinaryStream "Store this mono sound buffer in AIFF file format with the given sampling rate on the given stream." | sampleCount s swapBytes | sampleCount _ self monoSampleCount. aBinaryStream nextPutAll: 'FORM' asByteArray. aBinaryStream nextInt32Put: (2 * sampleCount) + ((7 * 4) + 18). aBinaryStream nextPutAll: 'AIFF' asByteArray. aBinaryStream nextPutAll: 'COMM' asByteArray. aBinaryStream nextInt32Put: 18. aBinaryStream nextNumber: 2 put: 1. "channels" aBinaryStream nextInt32Put: sampleCount. aBinaryStream nextNumber: 2 put: 16. "bits/sample" self storeExtendedFloat: rate on: aBinaryStream. aBinaryStream nextPutAll: 'SSND' asByteArray. aBinaryStream nextInt32Put: (2 * sampleCount) + 8. aBinaryStream nextInt32Put: 0. aBinaryStream nextInt32Put: 0. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization: write sound buffer directly to file" swapBytes _ SmalltalkImage current isLittleEndian. swapBytes ifTrue: [self reverseEndianness]. "make big endian" aBinaryStream next: (self size // 2) putAll: self startingAt: 1. "size in words" swapBytes ifTrue: [self reverseEndianness]. "revert to little endian" ^ self]. 1 to: sampleCount do: [:i | s _ self at: i. aBinaryStream nextPut: ((s bitShift: -8) bitAnd: 16rFF). aBinaryStream nextPut: (s bitAnd: 16rFF)]. ! ! !SoundBuffer methodsFor: 'objects from disk' stamp: 'sd 9/30/2003 13:46'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." | hack blt | SmalltalkImage current isLittleEndian ifTrue: [ "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 1. blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1" blt sourceX: 1; destX: 0; copyBits. blt sourceX: 0; destX: 1; copyBits. blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3" blt sourceX: 3; destX: 2; copyBits. blt sourceX: 2; destX: 3; copyBits]. ! ! !SunAudioFileWriter methodsFor: 'other' stamp: 'sd 9/30/2003 13:47'! appendSamples: aSoundBuffer "Append the given SoundBuffer to my stream." | swapBytes s | (stream isKindOf: StandardFileStream) ifTrue: [ "optimization: write sound buffer directly to file" swapBytes _ SmalltalkImage current isLittleEndian. swapBytes ifTrue: [aSoundBuffer reverseEndianness]. "make big endian" stream next: (aSoundBuffer size // 2) putAll: aSoundBuffer startingAt: 1. "size in words" swapBytes ifTrue: [aSoundBuffer reverseEndianness]. "revert to little endian" ^ self]. "for non-file streams:" s _ WriteStream on: (ByteArray new: 2 * aSoundBuffer monoSampleCount). 1 to: aSoundBuffer monoSampleCount do: [:i | s int16: (aSoundBuffer at: i)]. self appendBytes: s contents. ! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 7/2/2003 22:11'! makeExternalRelease "Smalltalk makeExternalRelease" (self confirm: SystemVersion current version , ' Is this the correct version designation? If not, choose no, and fix it.') ifFalse: [^ self]. "Object classPool at: #DependentsFields" Smalltalk reclaimDependents. Preferences enable: #mvcProjectsAllowed. Preferences enable: #fastDragWindowForMorphic. Browser initialize. Undeclared isEmpty ifFalse: [self halt]. ScriptingSystem deletePrivateGraphics. #(Helvetica Palatino Courier) do: [:n | TextConstants removeKey: n ifAbsent: []]. (Utilities classPool at: #UpdateUrlLists) copy do: [:pair | (pair first includesSubstring: 'Disney' caseSensitive: false) ifTrue: [ (Utilities classPool at: #UpdateUrlLists) remove: pair]]. (ServerDirectory serverNames copyWithoutAll: #('UCSBCreateArchive' 'UIUCArchive' 'UpdatesExtUIUC' 'UpdatesExtWebPage')) do: [:sn | ServerDirectory removeServerNamed: sn]. Smalltalk garbageCollect. Smalltalk obsoleteClasses isEmpty ifFalse: [self halt]. Symbol rehash. self halt: 'Ready to condense changes or sources'.! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 7/2/2003 22:11'! makeInternalRelease "Smalltalk makeInternalRelease" (self confirm: SystemVersion current version , ' Is this the correct version designation? If not, choose no, and fix it.') ifFalse: [^ self]. (Object classPool at: #DependentsFields) size > 1 ifTrue: [self halt]. Browser initialize. Undeclared isEmpty ifFalse: [self halt]. Smalltalk garbageCollect. self obsoleteClasses isEmpty ifFalse: [self halt]. Symbol rehash. self halt: 'Ready to condense changes'. Smalltalk condenseChanges! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 7/2/2003 22:11'! makeSqueaklandRelease "Smalltalk makeSqueaklandRelease" "NOTE: This method assumes that * ALL WINDOWS HAVE BEEN CLOSED (most importantly all project windows) * ALL GLOBAL FLAPS HAVE BEEN DESTROYED (not just disabled) This method may needs to be run twice - upon the first run you will probably receive an error message saying 'still have obsolete behaviors'. Close the notifier and try again. If there are still obsolete behaviors then go looking for them. Last update: ar 8/18/2001 01:14 for Squeak 3.1" | ss | (self confirm: SystemVersion current version , ' Is this the correct version designation? If not, choose no, and fix it.') ifFalse: [^ self]. "Delete all projects" Project allSubInstancesDo: [:p | p == Project current ifFalse: [Project deletingProject: p]]. "Fix up for some historical problem" self systemNavigation allObjectsDo: [:o | o isMorph ifTrue: [o removeProperty: #undoGrabCommand]]. "Hm ... how did this come in?!!" Smalltalk keys do: [:x | (x class == String and: [(Smalltalk at: x) isBehavior]) ifTrue: [Smalltalk removeKey: x]]. "Remove stuff from References" References keys do: [:k | References removeKey: k]. "Reset command history" CommandHistory resetAllHistory. "Clean out Undeclared" Undeclared removeUnreferencedKeys. "Reset scripting system" StandardScriptingSystem initialize. "Reset preferences" Preferences chooseInitialSettings; installBrightWindowColors. "Do a nice fat GC" Smalltalk garbageCollect. "Dependents mean that we're holding onto stuff" (Object classPool at: #DependentsFields) size > 1 ifTrue: [self error: 'Still have dependents']. "Set a few default preferences" #(#(#honorDesktopCmdKeys #false) #(#warnIfNoChangesFile #false) #(#warnIfNoSourcesFile #false) #(#showDirectionForSketches #true) #(#menuColorFromWorld #false) #(#unlimitedPaintArea #true) #(#useGlobalFlaps #false) #(#mvcProjectsAllowed #false) #(#projectViewsInWindows #false) #(#automaticKeyGeneration #true) #(#securityChecksEnabled #true) #(#showSecurityStatus #false) #(#startInUntrustedDirectory #true) #(#warnAboutInsecureContent #false) #(#promptForUpdateServer #false) #(#fastDragWindowForMorphic #false) ) do: [:spec | Preferences setPreference: spec first toValue: spec last == #true]. "Initialize Browser (e.g., reset recent classes etc)" Browser initialize. "Check for Undeclared" Undeclared isEmpty ifFalse: [self error: 'Please clean out Undeclared']. "Remove graphics we don't want" ScriptingSystem deletePrivateGraphics. "Remove a few text styles" #(#Helvetica #Palatino #Courier ) do: [:n | TextConstants removeKey: n ifAbsent: []]. "Dump all player uniclasses" Smalltalk at: #Player ifPresent: [:player | player allSubclassesDo: [:cls | cls isSystemDefined ifFalse: [cls removeFromSystem]]]. "Dump all Wonderland uniclasses" Smalltalk at: #WonderlandActor ifPresent: [:wnldActor | wnldActor allSubclassesDo: [:cls | cls isSystemDefined ifFalse: [cls removeFromSystem]]]. "Attempt to get rid of them" Smalltalk garbageCollect. "Now remove larger parts" Smalltalk discardFFI; discard3D; discardSUnit; discardSpeech; discardVMConstruction; discardPWS; discardIRC. "Dump change sets" ChangeSorter removeChangeSetsNamedSuchThat: [:cs | cs name ~= ChangeSet current name]. "Clear current change set" ChangeSet current clear. ChangeSet current name: 'Unnamed1'. Smalltalk garbageCollect. "Reinitialize DataStream; it may hold on to some zapped entitities" DataStream initialize. "Remove refs to old ControlManager" ScheduledControllers _ nil. "Flush obsolete subclasses" Behavior flushObsoleteSubclasses. Smalltalk garbageCollect. Smalltalk obsoleteBehaviors isEmpty ifFalse: [self error: 'Still have obsolete behaviors']. "Clear all server entries" ServerDirectory serverNames do: [:each | ServerDirectory removeServerNamed: each]. SystemVersion current resetHighestUpdate. ss _ Set allSubInstances. 'Rehashing all sets' displayProgressAt: Sensor cursorPoint from: 1 to: ss size during: [:bar | 1 to: ss size do: [:i | bar value: i. (ss at: i) rehash]]. Smalltalk obsoleteClasses isEmpty ifFalse: [self halt]. self halt: 'Ready to condense changes or sources'. SystemDictionary removeSelector: #makeSqueaklandRelease! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'sd 7/2/2003 22:18'! extraVMMemory "Answer the current setting of the 'extraVMMemory' VM parameter. See the comment in extraVMMemory: for details." self deprecatedExplanation: 'Use SmalltalkImage current extraVMMemory'. ^ Smalltalk vmParameterAt: 23 ! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'sd 7/2/2003 22:19'! extraVMMemory: extraBytesToReserve "Request that the given amount of extra memory be reserved for use by the virtual machine to leave extra C heap space available for things like plugins, network and file buffers, and so on. This request is stored when the image is saved and honored when the image is next started up. Answer the previous value of this parameter." self deprecatedExplanation: 'Use SmalltalkImage current extraVMMemory:'. extraBytesToReserve < 0 ifTrue: [self error: 'VM memory reservation must be non-negative']. ^ Smalltalk vmParameterAt: 23 put: extraBytesToReserve ! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'sd 7/3/2003 22:00'! vmParameterAt: parameterIndex "parameterIndex is a positive integer corresponding to one of the VM's internal parameter/metric registers. Answer with the current value of that register. Fail if parameterIndex has no corresponding register. VM parameters are numbered as follows: 1 end of old-space (0-based, read-only) 2 end of young-space (read-only) 3 end of memory (read-only) 4 allocationCount (read-only) 5 allocations between GCs (read-write) 6 survivor count tenuring threshold (read-write) 7 full GCs since startup (read-only) 8 total milliseconds in full GCs since startup (read-only) 9 incremental GCs since startup (read-only) 10 total milliseconds in incremental GCs since startup (read-only) 11 tenures of surving objects since startup (read-only) 12-20 specific to the translating VM 21 root table size (read-only) 22 root table overflows since startup (read-only) 23 bytes of extra memory to reserve for VM buffers, plugins, etc. 24 memory headroom when growing object memory (rw) 25 memory threshold above which shrinking object memory (rw)" ^ self deprecated: [self vmParameterAtDeprecatedPrimitive: parameterIndex] explanation: 'Use SmalltalkImage current vmParametersAt:' ! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'sd 7/3/2003 22:02'! vmParameterAt: parameterIndex put: newValue "parameterIndex is a positive integer corresponding to one of the VM's internal parameter/metric registers. Store newValue (a positive integer) into that register and answer with the previous value that was stored there. Fail if newValue is out of range, if parameterIndex has no corresponding register, or if the corresponding register is read-only." ^ self deprecated: [self vmParameterAtDeprecatedPrimitive: parameterIndex put: newValue] explanation: 'Use SmalltalkImage current vmParameterAt: parameterIndex put: newValue'! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'sd 7/3/2003 21:59'! vmParameterAtDeprecatedPrimitive: parameterIndex "parameterIndex is a positive integer corresponding to one of the VM's internal parameter/metric registers. Answer with the current value of that register. Fail if parameterIndex has no corresponding register. VM parameters are numbered as follows: 1 end of old-space (0-based, read-only) 2 end of young-space (read-only) 3 end of memory (read-only) 4 allocationCount (read-only) 5 allocations between GCs (read-write) 6 survivor count tenuring threshold (read-write) 7 full GCs since startup (read-only) 8 total milliseconds in full GCs since startup (read-only) 9 incremental GCs since startup (read-only) 10 total milliseconds in incremental GCs since startup (read-only) 11 tenures of surving objects since startup (read-only) 12-20 specific to the translating VM 21 root table size (read-only) 22 root table overflows since startup (read-only) 23 bytes of extra memory to reserve for VM buffers, plugins, etc. 24 memory headroom when growing object memory (rw) 25 memory threshold above which shrinking object memory (rw)" self primitiveFailed! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'sd 7/3/2003 22:02'! vmParameterAtDeprecatedPrimitive: parameterIndex put: newValue "parameterIndex is a positive integer corresponding to one of the VM's internal parameter/metric registers. Store newValue (a positive integer) into that register and answer with the previous value that was stored there. Fail if newValue is out of range, if parameterIndex has no corresponding register, or if the corresponding register is read-only." self primitiveFailed! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sd 9/30/2003 13:47'! setGCParameters "Adjust the VM's default GC parameters to avoid premature tenuring." SmalltalkImage current vmParameterAt: 5 put: 4000. "do an incremental GC after this many allocations" SmalltalkImage current vmParameterAt: 6 put: 2000. "tenure when more than this many objects survive the GC" ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sd 9/24/2003 12:15'! setPlatformPreferences "Set some platform specific preferences on system startup" self deprecatedExplanation: 'Use SmalltalkImage current setPlatformPreferences'. ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sd 9/24/2003 12:36'! unbindExternalPrimitives "Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found." ^ self deprecated: [self unbindExternalPrimitivesDeprecatedPrimitive ] explanation: 'Use SmalltalkImage unbindExternalPrimitives'. "Do nothing if the primitive fails for compatibility with older VMs"! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sd 9/24/2003 12:33'! unbindExternalPrimitivesDeprecatedPrimitive "Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found." "Do nothing if the primitive fails for compatibility with older VMs"! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 7/3/2003 22:08'! isBigEndian self deprecatedExplanation: 'Use SmalltalkImage current isBigEndian'. ^self endianness == #big! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 7/3/2003 22:08'! isLittleEndian self deprecatedExplanation: 'Use SmalltalkImage current isLittleEndian'. ^self endianness == #little! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 7/2/2003 22:11'! systemInformationString "Identify software version" ^ SystemVersion current version, String cr, self lastUpdateString, String cr, self currentChangeSetString " (eToySystem _ self at: #EToySystem ifAbsent: [nil]) ifNotNil: [aString _ aString, ' Squeak-Central version: ', eToySystem version, ' of ', eToySystem versionDate]."! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 7/2/2003 22:08'! version "Answer the version of this release." self deprecatedExplanation: 'Use SystemVersion current version'. ^SystemVersion current version! ! !SystemVersion methodsFor: 'accessing' stamp: 'mir 5/1/2001 18:19'! datedVersion "Answer the version of this release." ^ self version asString , ' of ' , self date printString! ! IdentityDictionary subclass: #SystemDictionary instanceVariableNames: 'cachedClassNames ' classVariableNames: 'LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore MemoryHogs ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp VersionString ' poolDictionaries: '' category: 'System-Support'! !SmalltalkImage reorganize! ('vm parameters' extraVMMemory extraVMMemory: getVMParameters vmParameterAt: vmParameterAt:put:) ('endian' endianness isBigEndian isLittleEndian) ('external' exitToDebugger unbindExternalPrimitives) ('quit' quitPrimitive) ('vm profiling' clearProfile dumpProfile profile: startProfiling stopProfiling) ('vm statistics' textMarkerForShortReport vmStatisticsReportString vmStatisticsShortString) ('system attribute' extractParameters getSystemAttribute: osVersion platformName platformSubtype vmVersion) ('preferences' setPlatformPreferences) ('modules' listBuiltinModule: listBuiltinModules listLoadedModule: listLoadedModules unloadModule:) ('image, changes names' imageName sourceFileVersionString sourcesName vmPath) ('private source file' sourceFileVersionString:) ! "Postscript: Leave the line above, and replace the rest of this comment by a useful one. Executable statements should follow this comment, and should be separated by periods, with no exclamation points (!!). Be sure to put any further comments in double-quotes, like this one." !